
Rozdzia 1.

ActiveWindow.ActivePane.View.Zoom.Percentage = 150

Sub AutoOpen()
      ActiveWindow.ActivePane.View.Zoom.Percentage = 150
End Sub



Sub AltH()
' Stosuje styl Nagwek 1
    Selection.Style = ActiveDocument.Styles("Nagwek 1")
End Sub
................................

Rozdzia 2.

Sub ShowDebug()

Dim x As Integer
x = 12

Debug.Print x

End Sub



Sub GoodCode()
  MsgBox "Ten kod dziaa."
End Sub

Sub BadCode()
  Application.Delete
End Sub



Sub GoodCode()
  MsgBox "Ten kod dziaa."
  BadCode
End Sub

................................

Rozdzia 3.

Sub transpose_word_right()
'
' Makro Transpose_Word_Right
' Przenosi biece sowo za sowo wystpujce po jego prawej stronie.
' Utworzya Nanci Luz Selest-Gomes 15-05-2019
'
    Selection.Extend
    Selection.Extend
    Selection.EscapeKey
    Selection.Cut
    Selection.MoveRight Unit:=wdWord, Count:=1
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
    Selection.MoveLeft Unit:=wdWord, Count:=1

End Sub



Sub Transpose_Word_Left()
'
' Makro Transpose_Word_Left
' Przenosi biece sowo za sowo wystpujce po jego lewej stronie. _
' Utworzya Nanci Selest-Gomes 5-05-2013
'
    Selection.Extend
    Selection.Extend
    Selection.EscapeKey
    Selection.Cut
    Selection.MoveLeft Unit:=wdWord, Count:=1
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
End Sub




Sub Add_Months()
'
' Makro Add_Months
' Wypenia miesice roku. Zarejestrowane 29/09/15 przez Abe Normal.
'
'
'
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Sty-2019"
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Lut-2019"
    Selection.AutoFill Destination:=Range("B1:L1"), Type:=xlFillDefault
 End Sub


Sub Add_Months()
'
' Makro Add_Months
' Wypenia miesice roku. Zarejestrowane 29/09/15 przez Abe Normal.
'
'
'
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Sty-2019"
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Lut-2019"
    Selection.AutoFill Destination:=Range("B1:L1"), Type:=xlFillDefault
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Sty-2019"
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Lut-2019"
    Selection.AutoFill Destination:=Range("B1:L1"), Type:=xlFillDefault
 End Sub


Sub Add_Months()
'
' Makro Add_Months
' Wypenia miesice roku. Zarejestrowane 29/09/15 przez Abe Normal.
'
'
'
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Sty-2019"
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Lut-2019"
    Selection.AutoFill Destination:=Range("B1:L1"), Type:=xlFillDefault
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "12"
    Selection.AutoFill Destination:=Range("A2:L2"), Type:=xlFillSeries
 End Sub





Sub Add_Slide_and_Format_Placeholder()
'
' Przykadowe makro, ktre dodaje slajd, formatuje jego "tekst zastpczy"
' i wprowadza tekst. Zarejestrowane 16/6/19 przez Batfielda Diala.
'
    ActiveWindow.View.GotoSlide Index:= _
        ActivePresentation.Slides.Add(Index:=2, _
        Layout:=ppLayoutText).SlideIndex
    ActiveWindow.Selection.SlideRange.Layout = ppLayoutTitle
    ActiveWindow.Selection.SlideRange.Shapes(1).Select
    With ActiveWindow.Selection.ShapeRange
        .IncrementLeft -6#
        .IncrementTop -125.75
    End With
    ActiveWindow.Selection.ShapeRange.ScaleHeight 1.56, msoFalse, _
        msoScaleFromTopLeft
    ActiveWindow.Selection.SlideRange.Shapes(1).Select
    ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
    ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters _
        (Start:=1, Length:=0).Select
    With ActiveWindow.Selection.TextRange
        . Text = "Szybki brzowy pies przeskoczy nad leniwym lisem"
        With .Font
            .Name = "Arial"
            .Size = 44
            .Bold = msoFalse
            .Italic = msoFalse
            .Underline = msoFalse
            .Shadow = msoFalse
            .Emboss = msoFalse
            .BaselineOffset = 0
            .AutoRotateNumbers = msoFalse
            .Color.SchemeColor = ppTitle
      End With
    End With
    ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters _
        (Start:=1, Length:=42).Select
    With ActiveWindow.Selection.TextRange.Font
        .Name = "Impact"
            .Size = 54
            .Bold = msoFalse
            .Italic = msoFalse
            .Underline = msoFalse
            .Shadow = msoFalse
            .Emboss = msoFalse
            .BaselineOffset = 0
            .AutoRotateNumbers = msoFalse
            .Color.SchemeColor = ppTitle
    End With
End Sub



Sub Add_Slide_and_Format_Placeholder()
'
' Przykadowe makro, ktre dodaje slajd, formatuje jego "tekst zastpczy"
' i wprowadza tekst.        Zarejestrowane 4-12-15 przez Rodneya Converse'a.
'
    ActiveWindow.View.GotoSlide Index:= _
        ActivePresentation.Slides.Add(Index:=2, _
        Layout:=ppLayoutText).SlideIndex
    ActiveWindow.Selection.SlideRange.Layout = ppLayoutTitle
    ActiveWindow.Selection.SlideRange.Shapes(1).Select
    With ActiveWindow.Selection.ShapeRange
      .IncrementLeft -6#
      .IncrementTop -125.75
     End With
     ActiveWindow.Selection.ShapeRange.ScaleHeight 1.56, msoFalse, _
         msoScaleFromTopLeft
     ActiveWindow.Selection.SlideRange.Shapes(1).Select
     ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
     ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters _
         (Start:=1, Length:=0).Select
     ActiveWindow.Selection.TextRange.Text = "Witaj w firmie Acme Industries"
     ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
     With ActiveWindow.Selection.TextRange.Font
         .Name = "Impact"
         .Size = 54
         .Bold = msoFalse
         .Italic = msoFalse
         .Underline = msoFalse
         .Shadow = msoFalse
         .Emboss = msoFalse
         .BaselineOffset = 0
         .AutoRotateNumbers = msoFalse
         .Color.SchemeColor = ppTitle
     End With
 End Sub


Rozdzia 4.

Sub temp()
'
' temp Macro
'
'
    With Options
        .InsertedTextMark = wdInsertedTextMarkUnderline
        .InsertedTextColor = wdRed
        .DeletedTextMark = wdDeletedTextMarkStrikeThrough
        .DeletedTextColor = wdRed
        .RevisedPropertiesMark = wdRevisedPropertiesMarkNone
        .RevisedPropertiesColor = wdByAuthor
        .RevisedLinesMark = wdRevisedLinesMarkOutsideBorder
        .CommentsColor = wdRed
        .RevisionsBalloonPrintOrientation = _
wdBalloonPrintOrientationPreserve
    End With
    ActiveWindow.View.RevisionsMode = wdMixedRevisions
    With Options
        .MoveFromTextMark = wdMoveFromTextMarkDoubleStrikeThrough
        .MoveFromTextColor = wdGreen
        .MoveToTextMark = wdMoveToTextMarkDoubleUnderline
        .MoveToTextColor = wdGreen
        .InsertedCellColor = wdCellColorLightBlue
        .MergedCellColor = wdCellColorLightYellow
        .DeletedCellColor = wdCellColorPink
        .SplitCellColor = wdCellColorLightOrange
    End With
    With ActiveDocument
        .TrackMoves = False
        .TrackFormatting = True
    End With
    With Options
        .InsertedTextMark = wdInsertedTextMarkUnderline
        .InsertedTextColor = wdRed
        .DeletedTextMark = wdDeletedTextMarkHidden
        .DeletedTextColor = wdRed
        .RevisedPropertiesMark = wdRevisedPropertiesMarkNone
        .RevisedPropertiesColor = wdByAuthor
        .RevisedLinesMark = wdRevisedLinesMarkOutsideBorder
        .CommentsColor = wdRed
        .RevisionsBalloonPrintOrientation = _
wdBalloonPrintOrientationPreserve
    End With
    ActiveWindow.View.RevisionsMode = wdMixedRevisions
    With Options
        .MoveFromTextMark = wdMoveFromTextMarkDoubleStrikeThrough
        .MoveFromTextColor = wdGreen
        .MoveToTextMark = wdMoveToTextMarkDoubleUnderline
        .MoveToTextColor = wdGreen
        .InsertedCellColor = wdCellColorLightBlue
        .MergedCellColor = wdCellColorLightYellow
        .DeletedCellColor = wdCellColorPink
        .SplitCellColor = wdCellColorLightOrange
    End With
    With ActiveDocument
        .TrackMoves = False
        .TrackFormatting = True
    End With
End Sub


Sub Toggle_Track_Changes_between_Hidden_and_Strikethrough()
    If Options.DeletedTextMark = wdDeletedTextMarkHidden Then
        Options.DeletedTextMark = wdDeletedTextMarkStrikeThrough
    ElseIf Options.DeletedTextMark = wdDeletedTextMarkStrikeThrough Then
        Options.DeletedTextMark = wdDeletedTextMarkHidden
    End If
End Sub



Sub Toggle_Track_Changes_between_Hidden_and_Strikethrough_2()
    With Options
        If .DeletedTextMark = wdDeletedTextMarkHidden Then
            .DeletedTextMark = wdDeletedTextMarkStrikeThrough
        ElseIf .DeletedTextMark = wdDeletedTextMarkStrikeThrough Then
            .DeletedTextMark = wdDeletedTextMarkHidden
        End If
    End With
End Sub




Private Sub Auto_Open()
    Application.WindowState = xlMaximized
    Application.RecentFiles(1).Open
End Sub



Private Sub Auto_Open()
On Error GoTo Problem
    Application.WindowState = xlMaximized
    Application.RecentFiles(1).Open
Exit Sub
Problem:
    MsgBox Error$ " & Application.RecentFiles(1).Path & " nie moe by otwarty."
End Sub




Sub Add_Title_Slide()
    Dim sldTitleSlide As Slide
    Set sldTitleSlide = ActivePresentation.Slides.Add(Index:=1, _
        Layout:=ppLayoutTitle)
    With sldTitleSlide
        .Shapes(1).TextFrame.TextRange.Text = _
            "Pollution Update: " & Date
        .Shapes(2).TextFrame.TextRange.Text = _
            "JMP Industrials"
    End With
End Sub



Sub ShowDate()
MsgBox ("Witaj! Dzi jest: " & Now)
End Sub

................................

Rozdzia 5.


Documents.Open "c:\temp\Sample Document.docm"
MsgBox ActiveDocument.Name
ActiveDocument.Words(1).Text = "Brana"
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Documents.Add
Selection.TypeText "Szybki brzowy lis przeskoczy nad leniwym psem."
Documents.Close SaveChanges:=wdDoNotSaveChanges
Application.Quit



Selection.TypeText "Szybki brzowy lis przeskoczy nad leniwym psem."



Documents.Open ReadOnly:=False, FileName:= "c:\temp\Example.docm", _
    ReadOnly:=False, ConfirmConversions:=True

Documents.Open FileName:="c:\temp\Example.docm", _
    ConfirmConversions:=True, ReadOnly:=False




'pobierz liczb paskw polece
    n = CommandBars.Count

'wywietl ich wszystkie nazwy
    For i = 1 To n
        Debug.Print CommandBars(i).Name
    Next i




Private Sub Document_Close()

Dim intAnswer As Integer

intAnswer = MsgBox("Czy chcesz sprawdzi pisowni?", _
        vbOKCancel, "Dokument jest zamykany")

If intAnswer = 1 Then ' kliknito OK. 1 = OK 2 = Cancel

    ThisDocument.CheckSpelling 
End If

End Sub



Rozdzia 6.


myVariable = "Przykadowy zmienny tekst"
MsgBox myVariable



Sub Create_Weekly_Report()
    Dim strSupervisor As String
    Dim lngController As Long
. . .
End Sub



Dim strSupervisor As String
Private blnConsultantAssigned As Boolean

Sub Assign_Personnel()
. . .
End Sub



Option Explicit
Public intMyVar As Integer




Public strCurrentUser As String

Sub AutoExec()
    strCurrentUser = InputBox("Wprowad imi i nazwisko.", _
        "Tosamo biecego uytkownika")
End Sub

Sub Identify_Current_User()
    MsgBox "Biecy uytkownik to " & strCurrentUser, _
        vbOKOnly + vbInformation, "Biecy uytkownik"
End Sub



Sub ToggleItal()

Static switch As Boolean

switch = Not switch

If switch Then
    MsgBox "wczony"
Else
    MsgBox "wyczony"
End If

End Sub




Dim blnProduct_Available As Boolean
blnProduct_Available = True

If blnProduct_Available = True Then
    MsgBox "Produkt jest dostpny."
Else             'blnProduct_Available = False
    MsgBox "Produkt nie jest dostpny."
End If



Sub Calculate_Weekly_Salary()
    Salary@ = InputBox("Wprowad swoje roczne dochody.", _
        "Obliczanie tygodniowej pensji")
    WeeklySalary@ = Salary / 52
    MsgBox WeeklySalary
End Sub




Dim intMyVar As Integer
For intMyVar = 1 to 300
    'powtarzaj dziaania
Next intMyVar





Const conVenue As String = "Davies Hall"
Const conDate As Date = #December 31, 2019#
MsgBox "Koncert artysty " & conVenue & " odbdzie si dnia " _
& conDate & "."




Rozdzia 7.


Option Base 1

Dim strLocations(6) As String
strLocations(1) = "Londyn"
strLocations(2) = "Hong Kong"
strLocations(3) = "Tajpej"


If IsArray(MyVariable) = True Then
    Msg = "MyVariable" & " jest tablic."
Else
    Msg = "MyVariable" & " nie jest tablic."
End If
MsgBox Msg, vbOKOnly + vbInformation, "Sprawdzanie tablic"




Option Explicit
Option Base 1

Sub Sort_an_Array()

    'deklaracja tablicy i innych zmiennych
    Dim strArray(12) As String
    Dim strTemp As String
    Dim strMsg As String
    Dim X As Integer, Y As Integer, i As Integer

    'przypisanie cigw znakw do tablicy
     strArray(1) = "nihilizm"
     strArray(2) = "defetyzm"
     strArray(3) = "nadzieja"
     strArray(4) = "smutek"
     strArray(5) = "euforia"
     strArray(6) = "przygnbienie"
     strArray(7) = "optymizm"
     strArray(8) = "pesymizm"
     strArray(9) = "ndza"
     strArray(10) = "szczcie"
     strArray(11) = "bogo"
     strArray(12) = "mania"
     strMsg = "Biecy element w tablicy:" & vbCr & vbCr
     For i = 1 To UBound(strArray)
        strMsg = strMsg & i & ":" & vbTab & strArray(i) & vbCr
    Next i
    MsgBox strMsg, vbOKOnly + vbInformation, "Sortowanie tablicy: 1"

    For X = LBound(strArray) To (UBound(strArray) - 1)
        For Y = (X + 1) To UBound(strArray)
            If strArray(X) > strArray(Y) Then
                strTemp = strArray(X)
                strArray(X) = strArray(Y)
                strArray(Y) = strTemp
                strTemp = ""
            End If
        Next Y
    Next X

    strMsg = "Elementy w posortowanej tablicy:" & vbCr & vbCr
    For i = 1 To UBound(strArray)
        strMsg = strMsg & i & ":" & vbTab & strArray(i) & vbCr
    Next i
    MsgBox strMsg, vbOKOnly + vbInformation, "Sortowanie tablicy: 2"

 End Sub




Option Explicit
Option Base 1

Sub Linear_Search_of_Array()

    ' deklaracje tablicy i zmiennych
    Dim intArray(10) As Integer
    Dim i As Integer
    Dim varUserNumber As Variant
    Dim strMsg As String

    'dodanie do tablicy losowych liczb o wartociach od 0 do 10
    'i wywietlenie ich w oknie Immediate
    For i = 1 To 10
        intArray(i) = Int(Rnd * 10)
        Debug.Print intArray(i)
    Next i

 Loopback:
     varUserNumber = InputBox _
         ("Wpisz liczb od 1 do 10 do wyszukania:", _
         "Demo przeszukiwania liniowego")
     If varUserNumber = "" Then End
     If Not IsNumeric(varUserNumber) Then GoTo Loopback
     If varUserNumber < 1 Or varUserNumber > 10 Then GoTo Loopback

     strMsg = "Podanej wartoci: " & varUserNumber & _
         ", nie znaleziono w tablicy."

     For i = 1 To UBound(intArray)
         If intArray(i) = varUserNumber Then
             strMsg = "Podana warto, " & varUserNumber & _
                 ", zostaa znaleziona na pozycji " & i & " w tablicy."
             Exit For
         End If
     Next i

     MsgBox strMsg, vbOKOnly + vbInformation, "Wynik przeszukiwana liniowego"

 End Sub





Option Explicit
Option Base 1

Sub Binary_Search_of_Array()

    'deklaracja tablicy i zmiennych
    Dim intThousand(1000) As Integer
    Dim i As Integer
    Dim intTop As Integer
    Dim intMiddle As Integer
    Dim intBottom As Integer
    Dim varUserNumber As Variant
    Dim strMsg As String

    'wypenienie tablicy kolejnymi liczbami  od 1 do 1000
    For i = 1 To 1000
        intThousand(i) = i
    Next i

     'wywietlenie uytkownikowi proby o podanie elementu do wyszukania
 Loopback:
     varUserNumber = InputBox _
         ("Wprowad liczb od 1 do 1000 do wyszukania:", _
         "Demonstracja wyszukiwania binarnego")
     If varUserNumber = "" Then End
     If Not IsNumeric(varUserNumber) Then GoTo Loopback

     'wyszukiwanie elementu
     intTop = UBound(intThousand)
     intBottom = LBound(intThousand)

     Do
         intMiddle = (intTop + intBottom) / 2
         If varUserNumber > intThousand(intMiddle) Then
            intBottom = intMiddle + 1
         Else
             intTop = intMiddle - 1
         End If
     Loop Until (varUserNumber = intThousand(intMiddle)) _
         Or (intBottom > intTop)

     ' ustalenie, czy w wyniku operacji przeszukiwania znaleziono szukany element _
      czy te go nie znaleziono i dodanie odpowiedniej informacji do zmiennej strMsg
     If varUserNumber = intThousand(intMiddle) Then
         strMsg = "Wyszukiwany element, " _
             & varUserNumber & ", znaleziono w tablicy na pozycji " & intMiddle _
             & "."
     Else
             strMsg = "Nie znaleziono szukanego elementu " _
                 & varUserNumber & "."
     End If

     MsgBox strMsg, vbOKOnly & vbInformation, "Wynik wyszukiwania binarnego"

End Sub


Rozdzia 8

Sub Add_Item_to_AutoCorrect()
'
' Makro Add_Item_to_AutoCorrect
' Zamienia ref na referencje
'
    AutoCorrect.Entries.Add Name:="reffs", Value:="references"
    With Options
        .AutoFormatAsYouTypeApplyHeadings = False
        .AutoFormatAsYouTypeApplyBorders = True
        .AutoFormatAsYouTypeApplyBulletedLists = True
        .AutoFormatAsYouTypeApplyNumberedLists = True
        .AutoFormatAsYouTypeApplyTables = True
        .AutoFormatAsYouTypeReplaceQuotes = True
        .AutoFormatAsYouTypeReplaceSymbols = True
        .AutoFormatAsYouTypeReplaceOrdinals = True
        .AutoFormatAsYouTypeReplaceFractions = True
        .AutoFormatAsYouTypeReplacePlainTextEmphasis = False
        .AutoFormatAsYouTypeReplaceHyperlinks = True
        .AutoFormatAsYouTypeFormatListItemBeginning = True
        .AutoFormatAsYouTypeDefineStyles = False
        .TabIndentKey = True
    End With
    With AutoCorrect
        .CorrectInitialCaps = True
        .CorrectSentenceCaps = True
        .CorrectDays = True
        .CorrectCapsLock = True
        .ReplaceText = True
        .ReplaceTextFromSpellingChecker = True
        .CorrectKeyboardSetting = False
        .DisplayAutoCorrectOptions = True
        .CorrectTableCells = True
    End With
    With OMathAutoCorrect
        .UseOutsideOMath = False
        .ReplaceText = True
    End With
    With Options
        .AutoFormatApplyHeadings = True
        .AutoFormatApplyLists = True
        .AutoFormatApplyBulletedLists = True
        .AutoFormatApplyOtherParas = True
        .AutoFormatReplaceQuotes = True
        .AutoFormatReplaceSymbols = True
        .AutoFormatReplaceOrdinals = True
        .AutoFormatReplaceFractions = True
        .AutoFormatReplacePlainTextEmphasis = True
        .AutoFormatReplaceHyperlinks = True
        .AutoFormatPreserveStyles = True
        .AutoFormatPlainTextWordMail = True
    End With
    Options.LabelSmartTags = False
End Sub




Sub Add_Item_to_AutoCorrect()
'
' Makro Add_Item_to_AutoCorrect
' Zamienia ref na referencje
'
    AutoCorrect.Entries.Add Name:="reffs",Value:="references"
End Sub




Rozdzia 9.

Dim strExample As String
Dim strLeft10 As String
strExample = "Technika jest interesujca."
strLeft10 = Left(strExample, 10)
MsgBox strLeft10




Dim str1 As String
Dim str2 As String
str1 = Left("To jest duma i patriotyzm", 12)
str2 = Right(str1, 4)
MsgBox str2




Dim varMyInput
Dim intMyVar As Integer
varMyInput = InputBox("Podaj liczb cakowit:", "10 zwraca True, inne liczby zwracaj False")
intMyVar = CInt(varMyInput)
MsgBox CBool(intMyVar = 10)



strThisCharacter = Asc(Selection.Text)
MsgBox strThisCharacter, vbOKOnly, "Character Code"



Dim StrVar As String
StrVar = "12,000"
MsgBox "Val = " & Val(StrVar) & "  CInt = " & CInt(StrVar)



Sub Age()
    Dim intAge As Integer, strYourAge As String
    intAge = InputBox("Podaj swj wiek:", "Wiek")
    strYourAge = "Twj wiek to " & CInt (intAge) & "."
    MsgBox strYourAge, vbOKOnly + vbInformation, "Wiek"
End Sub



Sub FormatTabular()
Dim i As Integer
Dim strFirstName As String
Dim strLastName As String
Dim strAddress As String
Dim strCity As String
Dim strState As String
Dim strAllInfo As String
strFirstName = "Filip"
strLastName = "Makowski"
strAddress = "Baczewskiego 12"
strCity = "Tuchola"
strState = "POM"
    strAllInfo = strFirstName & vbTab & strLastName _
        & vbTab & strAddress & vbTab & strCity _
        & vbTab & strState & vbCr
    Selection.TypeText strAllInfo
End Sub



Dim strPhone As String
strPhone = "5105551212"
MsgBox Mid(strPhone, 4, 3)




Dim strFilename As String, intLen As Integer
strFilename = ActiveDocument.AttachedTemplate.FullName
MsgBox strFilename
intLen = Len(strFilename)
Do Until Mid(strFilename, intLen, 1) = "\"
    intLen = intLen - 1
Loop
MsgBox Right(strFilename, Len(strFilename) - intLen)



Sub Save_in_Out_Folder()
    Dim strOName As String, strNName As String, _
        intToChange As Integer
    strOName = ActiveDocument.FullName
    intToChange = InStr(strOName, "\In\")
    strNName = Left(strOName, intToChange - 1) & "\Out\" _
        & Right(strOName, Len(strOName) - intToChange - 3)
    ActiveDocument.SaveAs strNName
End Sub




Sub CheckPassword()
    Dim strPassword As String
BadPassword:
    strPassword = InputBox _
        ("Wprowad haso, aby chroni ten element przed modyfikacj:" _
            , "Wprowad haso")
    If Len(strPassword) = 0 Then
             End
    ElseIf Len(strPassword) < 6 Then
        MsgBox "Haso, ktre wybrae, jest zbyt krtkie." _
            & vbCr & vbCr & _
            "Wybierz haso o dugoci pomidzy 6 a 15 znakw.", _
             vbOKOnly + vbCritical, "Niewaciwe haso"
        GoTo BadPassword
    ElseIf Len(strPassword) > 15 Then
        MsgBox "Haso, ktre wybrae jest zbyt dugie." _
            & vbCr & vbCr & _
            "Wybierz haso o dugoci pomidzy 6 a 15 znakw.", _
          vbOKOnly + vbCritical, "Niewaciwe haso"
        GoTo BadPassword
    End If
 End Sub




If 1 = 1 Then MsgBox "Jeden wynosi jeden."


strPet = InputBox("Czy Twj pupil to pies, czy kot?", "Pupil")
If strPet = "Pies" Then MsgBox "Nie przyjmujemy psw."


If Pet = "Pies" Or Pet = "pies" Or Pet = "PIES" Or Pet = "psy" _
    Or Pet = "Psy" or Pet = "PSY" Then MsgBox _
    "Nie przyjmujemy psw."



If StrComp(strPet, "pies", vbTextCompare) = 0 Then _
    MsgBox "Nie przyjmujemy psw."



If LCase(strPet)= "pies" Then _
    MsgBox "Nie przyjmujemy psw."



Sub Does_File_Exist()
    Dim strTestFile As String, strNameToTest As String, _
        strMsg As String
    strNameToTest = InputBox("Wprowad nazw pliku i ciek:")
    If strNameToTest = "" Then End
    strTestFile = Dir(strNameToTest)
    If Len(strTestFile) = 0 Then
        strMsg = "Plik " & strNameToTest & _
            " nie istnieje."
    Else
        strMsg = "Plik " & strNameToTest & " istnieje. "
    End If
    MsgBox strMsg, vbOKOnly + vbInformation, _
       "Sprawdzenie istnienia pliku"
 End Sub



Rozdzia 10.

Function AddStateTax(SubTotal)

 AddStateTax = SubTotal * 1.07 ''wykonaj dziaania i przypisz wynik
                          ' do nazwy funkcji, aby mona je byo przekaza na zewntrz

End Function



Sub Average()

       Dim n As Integer, m As Integer, o As Integer
       m = 12
       n = 10

       o = GetTempAve(n, m)
 
End Sub

Function GetTempAve(MaxTemp As Double, MinTemp As Double)

       GetTemps = MaxTemp + MinTemp / 2

End Function



Sub ShowProfit()
    MsgBox (NetProfit(44000, 34000)),, "Zysk netto"
End Sub

Function NetProfit(Gross As Double, Expenses As Double) As Double
    NetProfit = (Gross - Expenses) * 0.9
End Function




Sub TestForSmog()
    Dim intCYear As Integer, strThisCar As String
BadValueLoop:
    On Error GoTo Bye
    intCYear = InputBox("Podaj rocznik swojego samochodu.", _
        "Czy musz sprawdzi jako spalin?")
    strThisCar = NeedsSmog(intCYear)
    If strThisCar = "Yes" Then
        MsgBox "Powiniene sprawdzi jako spalin Twojego samochodu.", _
        vbOKOnly + vbExclamation, "Sprawdzenie spalin"
    ElseIf strThisCar = "BadValue" Then
        MsgBox "Wprowadzony rocznik samochodu oznacza dat w przyszoci.", _
        vbOKOnly + vbCritical, "Smog Check"
        GoTo BadValueLoop
    Else
        MsgBox "Twj samochd nie wymaga sprawdzenia spalin.", _
        vbOKOnly + vbInformation, "Sprawdzenie spalin"
    End If
 Bye:
 End Sub

 Function NeedsSmog(CarYear As Integer) As String
     If CarYear > Year(Now) Then
         NeedsSmog = "BadValue"
     ElseIf CarYear <= Year(Now) - 3 Then
         NeedsSmog = "Tak"
     Else
         NeedsSmog = "Nie"
     End If
 End Function




Option Explicit

Function Strip_Hyperlinks_Bookmarks_Fields()
    Dim myLink As Hyperlink
    Dim myBookmark As Bookmark
    Dim myField As Field
    With ActiveDocument
        For Each myLink In .Hyperlinks
            myLink.Delete
        Next myLink
        For Each myBookmark In .Bookmarks
            myBookmark.Delete
        Next myBookmark
        For Each myField In .Fields
            myField.Unlink
        Next myField
    End With
 End Function

 Sub Clean_Up_Document_for_Conversion()
     Call Strip_Hyperlinks_Bookmarks_Fields
     'other cleanup functions here
 End Sub




 Option Explicit

 Function BlankSheetsInWorkbook(ByRef WorkbookToTest As Workbook) As Boolean
     Dim objWorksheet As Worksheet
     BlankSheetsInWorkbook = False
     For Each objWorksheet In WorkbookToTest.Worksheets
         If Application.WorksheetFunction.CountBlank _
             (objWorksheet.Range("A1:IV65536")) = 16777216 Then
             BlankSheetsInWorkbook = True
             Exit Function
         End If
     Next objWorksheet
.End Function

  Sub Check_Workbook_for_Blank_Worksheets()
      If BlankSheetsInWorkbook(ActiveWorkbook) = True Then
          MsgBox "Ten skoroszyt zawiera jeden lub wicej pustych arkuszy." & _
              vbCr & vbCr & "Usu wszystkie puste arkusze, zanim " & _
              "przelesz skoroszyt.", vbOKOnly & vbExclamation, _
              "Sprawdzenie, czy w skoroszycie s puste arkusze"
      End If
  End Sub





Option Explicit

Function CheckMinFontSize(objPresentation As Presentation) As Boolean

    Dim objSlide As Slide
    Dim objShape As Shape

    CheckMinFontSize = True

    For Each objSlide In objPresentation.Slides
        objSlide.Select
        objSlide.Shapes.SelectAll
        For Each objShape In Windows(1).Selection.ShapeRange
            If objShape.Type = msoPlaceholder Then
                If objShape.TextFrame.TextRange.Font.Size < 14 Then
                    CheckMinFontSize = False
                    Exit Function
                End If
            End If
        Next objShape
    Next objSlide
 End Function

 Sub Font_Check()
     If CheckMinFontSize(ActivePresentation) = False Then
         MsgBox "Niektre czcionki w prezentacji s zbyt mae." _
         & vbCr & vbCr & "Zmie wszystkie czcionki na 14 punktw lub wiksze.",
         vbCritical + vboKonly, "Sprawdzenie rozmiaru czcionek"
    End If
 End Sub




 Function MoveToNew()

     DoCmd.OpenForm "Contact List"
     DoCmd.GoToRecord , , acNewRec

 End Function




Rozdzia 11.


Dim objTest1 As Object
Dim objTest2 As Object
Set objTest1 = ActiveDocument.Paragraphs(1).Range
Set objTest2 = ActiveDocument.Paragraphs(1).Range
'nastpna instrukcja zwrci False, poniewa te obiekty s rne
MsgBox objTest1 Is objTest2







Dim objTest1 As Object
Dim objTest2 As Object
Dim objTest3 As Object
Set objTest3 = ActiveDocument.Paragraphs(1).Range
Set objTest1 = objTest3
Set objTest2 = objTest3
' nastpna instrukcja zwrci True, poniewa
' objTest1 i objTest2 odwouj si do tego samego obiektu
MsgBox objTest1 Is objTest2




Dim strShort As String
strShort = Selection.Text
If Len(strShort) > 1 And _
  Mid(strShort, Len(strShort) - 1, 1) = "T" Then
  MsgBox "Drugi znak od koca to T."
End If




If Len(strShort) > 1 Then
  If Mid(strShort, Len(strShort) - 1, 1) = "T" Then
    MsgBox "Drugi znak od koca to T."
  End If
End If


Dim bytAge As Integer
bytAge = InputBox("Wprowad swj wiek.", "Wiek")
If bytAge < 18 Then MsgBox "Nie wolno Ci kupowa alkoholu.",, "Nieletni"



If bytAge < 21 Then If bytAge > 18 Then MsgBox _
    "Moesz gosowa, ale nie moesz zawrze maestwa.",, "Nieletni": End



If bytAge < 18 Then
    MsgBox "Nie wolno Ci kupowa alkoholu.",, "Nieletni"
    End
End If



Sub Electronic_Book_Critic()

  Dim intBookPages As Integer

  intBookPages = InputBox _
         ("Wprowad liczb stron ostatniej ksiki, ktr czytae.", _
          "Krytyk ksiek elektronicznych")
  If intBookPages > 1000 Then
    MsgBox "Ta ksika jest bardzo gruba.", vbOKOnly _
               + vbExclamation, "Krytyk ksiek elektronicznych"
  Else
    MsgBox "Ta ksika nie jest zbyt gruba.", vbOKOnly _
               + vbInformation, "Krytyk ksiek elektronicznych"
  End If

End Sub


Rozdzia 12.

Dim i As Integer
For i = 1 To 24
    ActiveCell.FormulaR1C1 = i & ":00"
    ActiveCell.Offset(RowOffset:=1, ColumnOffset:=0).Select
Next i



Dim i As Integer
For i = ActiveDocument.Paragraphs.Count To 0 Step -1
    CheckParagraphForIllegalFormatting
    Application.StatusBar = _
        " Czekaj, a Word sprawdzi formatowanie w tym dokumencie: " & i
    Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdMove
Next i



Sub CreatePresentations()
    Dim intPresentations As Integer
    Dim i As Integer
    intPresentations = InputBox _
        ("Wprowad liczb prezentacji do utworzenia:", _
         "Tworzenie prezentacji")
    For i = 1 To intPresentations
        Presentations.Add
    Next i
End Sub



Sub makefolders()

      Dialogs(wdDialogFileSaveAs).Show

      Load frmCreateFolders

      frmCreateFolders.Show

End Sub




Private Sub cmdOK_Click()

    Dim strMsg As String
    Dim strFolder As String
    Dim i As Integer

    frmCreateFolders.Hide
    Unload frmCreateFolders
    strMsg = "Procedura Create_Folders stworzya " _
          & "nastpujce foldery: " & vbCr & vbCr

    For i = 1 To txtFolders.Value
        strFolder = txtProjectNumber.Value & "p" & Format(i, "0#")
        MkDir strFolder
        strMsg = strMsg & "    " & strFolder & vbCr
    Next i

    MsgBox strMsg, vbOKOnly + vbInformation, _
        "Tworzenie folderw"

End Sub




Sub GenerateGlossary()

    Dim strSource As String
    Dim strDestination As String
    Dim strGlossaryName As String

    strSource = ActiveWindow.Caption
    strGlossaryName = InputBox _
        ("Wprowad nazw dokumentu, dla ktrego tworzysz sowniczek.", _
         "Tworzenie sowniczka")
    If strGlossaryName = "" Then End

    Documents.Add
    ActiveDocument.SaveAs FileName:=strGlossaryName, _
        FileFormat:=wdFormatDocument
    strDestination = ActiveWindow.Caption
    Windows(strSource).Activate

    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Font.Italic = True
    Selection.Find.Font.Name = "Times New Roman"
    Selection.Find.Text = ""
    Selection.Find.Execute

    Do While Selection.Find.Found
        Selection.Copy
        Selection.MoveRight Unit:=wdCharacter, _
            Count:=1, Extend:=wdMove
        Windows(strDestination).Activate
        Selection.EndKey Unit:=wdStory
        Selection.Paste
        Selection.TypeParagraph
        Windows(strSource).Activate
        Selection.Find.Execute
    Loop

    Windows(strDestination).Activate
    ActiveDocument.Save
    ActiveDocument.Close

End Sub



Dim varPassword As Variant
VarPassword = "corinth"
Do
    varPassword = InputBox _
        ("Enter the password to start the procedure:", _
        "Check Password 1.0")
Loop While varPassword <> "CorrectPassword"




Do
    varPassword = InputBox _
        ("Aby rozpocz procedur, wprowad haso:", _
        "Sprawdzanie hasa 1.0")
    If varPassword = "" Then End
Loop While varPassword <> "PoprawneHaso"




Sub Lottery_1()
    Dim intWin As Integer
    Do Until intWin > 2000
        intWin = Rnd * 2100
        MsgBox intWin, , "Lottery"
    Loop
End Sub




Sub FindNextHeading()
    Do Until Left(Selection.Paragraphs(1).Style, 7) = "Heading"
        Selection.MoveDown Unit:=wdParagraph, _
            Count:=1, Extend:=wdMove
    Loop
End Sub




Sub Create_Worksheets()
    Dim strNewSheet As String
    Do
        strNewSheet = InputBox _
            ("Podaj nazw nowego arkusza " _
            & "(maksymalnie 31 znakw):", "dodaj arkusze")
        If strNewSheet <> "" Then
            ActiveWorkbook.Worksheets.Add
            ActiveSheet.Name = strNewSheet
        End If
    Loop Until strNewSheet = ""
End Sub



Sub Lottery_2()
    Dim intWin As Integer
    Do Until intWin > 2000
        intWin = Rnd * 2100
        If intWin < 500 Then
            MsgBox "Pech. Zostae zdyskwalifikowany.", _
                   vbOKOnly + vbCritical, "Loteria"
            Exit Do
        End If
        MsgBox intWin, , "Lottery"
    Loop
End Sub




 Sub Lottery_3()

 Dim intWin As Integer

 Do
     intWin = Rnd * 2100
     MsgBox intWin, , "Loteria"
 Loop Until intWin > 2000 Or intWin < 500


 If intWin < 500 Then
     MsgBox "Pech. Zostae zdyskwalifikowany.", _
                 vbOKOnly + vbCritical, "Lottery"
 End If

 End Sub




Private Sub cmdOK_Click()

    Dim strStartingFolder As String
    Dim strFolderName As String
    Dim strSubfolderName As String
    Dim intSubfolder As Integer
    Dim intLoopCounter As Integer

    frmCreateFoldersAndSubfolders.Hide
    Unload frmCreateFoldersAndSubfolders

    strStartingFolder = CurDir

    For intLoopCounter = 1 To txtHowManyFolders.Value
        strFolderName = txtProjectNumber.Value & "s" & _
            Format(intLoopCounter, "0#")
        MkDir strFolderName
        ChDir strFolderName
        For intSubfolder = 1 To txtHowManySubfolders.Value
            strSubfolderName = "Podpunkt" & intSubfolder
            MkDir strSubfolderName
        Next intSubfolder
        ChDir strStartingFolder
    Next intLoopCounter

End Sub


 Sub InfiniteLoop()
     Dim x
     x = 1
     Do
         Application.StatusBar = _
            "Komputer jest zablokowany w ptli nieskoczonej: " & x
         x = x + 1
     Loop
 End Sub




Rozdzia 13.



Dim strMsg As String
strMsg = "To jest proste okno komunikatu."
MsgBox strMsg



Dim strMsg As String
strMsg = "Word zakoczy formatowanie danego raportu." _
    & vbCr & vbCr & "Moesz teraz uruchomi ponisze procedury:" & vbCr _
    & vbCr & Chr(149) & " Procedura Distribute_Report wyle raport emailem do " _
    & "centrali firmy." & vbCr & vbCr & Chr(149) & _
    " Procedura Store_Report skopiuje raport do wskazanego katalogu." _
    & vbCr & vbCr & Chr(149) & " Procedura Backup_Report stworzy kopi zapasow " _
    & "raportu na serwerze plikw."
MsgBox strMsg



Dim lngQuery As Long
lngQuery = MsgBox("Czy chesz usun t prezentacj?", _
    vbYesNo + vbCritical + vbDefaultButton2)



Dim lngQuery As Long
lngQuery = MsgBox("Czy chcesz usun ten skoroszyt?", vbYesNo _
    + vbCritical + vbDefaultButton2, "Usu skoroszyt 12.39")



lngQuery = MsgBox("Czy chcesz usun ten skoroszyt?", vbYesNo _
    + vbCritical + vbDefaultButton2 + vbMsgBoxHelpButton , _
    "Usu skoroszyt")


Dim lngQuery As Long
lngQuery = MsgBox("Czy chcesz usun ten skoroszyt?", vbYesNo _
    + vbCritical + vbDefaultButton2 + vbMsgBoxHelpButton, _
    "Usu skoroszyt", "c:\Windows\Help\My_Help.chm", 1012)



Response = MsgBox("Czy chcesz sformatowa raport?",,, _
    "c:\Windows\Help\Macro Help.chm", 1012


Dim lngResponse As Long

lngResponse = MsgBox("Czy chcesz utworzy raport dzienny?", _
    vbYesNo + vbQuestion, "Tworzenie raportu dziennego")


Dim lngUserChoice As Long
lngUserChoice = MsgBox("Czy chcesz utworzy raport dzienny?", _
    vbYesNo + vbQuestion, "Tworzenie dziennego raportu")
If lngUserChoice = vbYes Then
    Goto CreateDailyReport
Else
    Goto Bye
EndIf


Dim strAuthor As String
  strAuthor = _
  ActiveDocument.BuiltInDocumentProperties(wdPropertyLastAuthor)



Dim strWhichOffice As String
strWhichOffice = InputBox( _
    "Wprowad nazw biura, ktre odwiedzie:", _
    "Asystent wydatkw", "Madryt", , , _
    "c:\Windows\Help\Procedure Help.chm", 0)



Dim strWhichOffice

strWhichOffice = _
    "Wprowad nazw biura, ktre odwiedzie:", _
    "Asystent wydatkw 2000", "Madryt", , , _
    "c:\Windows\Help\Procedure Help.chm", 0)



strWhichOffice = InputBox _
    "Wprowad nazw biura, ktre odwiedzie:", _
    "Asystent wydatkw 2000", "Madryt", , , _
    "c:\Windows\Help\Procedure Help.chm", 0)

If strWhichOffice = "" Then End



Rozdzia 14.


Sub Display_Dialog()
    Load frmMyDialog 'aduje formularz do pamici
    frmMyDialog.Show 'wywietla formularz
End Sub


Sub Display_Dialog()
    frmMyDialog.Show 'aduje formularz do pamici i go wywietla
End Sub




If optSearchForFile = True Then
    'wybrano optSearchForFile; podejmij dziaania w odpowiedzi
Else 'opcja optSearchForFile nie zostaa zaznaczona, zatem zaznaczono opcj optUseThisFile
    'podejmij dziaania dla opcji optUseThisFile
End If



strMsg = "Wybrano nastpujce pozycje z listy: " & vbCr
For i = 1 To lstBatteries.ListCount
  If lstBatteries.Selected(i - 1) = True Then
    strMsg = strMsg & lstBatteries.List(i - 1) & vbCr
  End If
Next i
MsgBox strMsg



Private Sub UserForm_Initialize()
    cmbColor.AddItem "Czerwony"
    cmbColor.AddItem "Niebieski"
    cmbColor.AddItem "ty"
End Sub




Sub Move_Paragraph()
'
' Makro Move_Paragraph
' Przenosi akapit w gr lub w d
'
    With ActiveDocument.Bookmarks
        .Add Range:=Selection.Range, Name:="Move_Paragraph_Temp"
        .DefaultSorting = wdSortByName
        .ShowHidden = False
    End With
    Selection.Extend
    Selection.Extend
    Selection.Extend
    Selection.Extend
    Selection.EscapeKey
    Selection.Cut
    Selection.MoveUp Unit:=wdParagraph, Count:=1
    Selection.Paste
    Selection.MoveDown Unit:=wdParagraph, Count:=1
    Selection.MoveUp Unit:=wdParagraph, Count:=2
    Selection.MoveDown Unit:=wdParagraph, Count:=2
    Selection.GoTo What:=wdGoToBookmark, Name:="Move_Paragraph_Temp"
    ActiveDocument.Bookmarks("Move_Paragraph_Temp").Delete
    With ActiveDocument.Bookmarks
        .DefaultSorting = wdSortByName
        .ShowHidden = False
    End With
End Sub






Sub Move_Paragraph()
    ActiveDocument.Bookmarks.Add Range:=Selection.Range, _
        Name:="Move_Paragraph_Temp"
    Selection.Extend
    Selection.Extend
    Selection.Extend
    Selection.Extend
    Selection.EscapeKey
    Selection.Cut
    Selection.MoveUp Unit:=wdParagraph, Count:=1
    Selection.Paste
    Selection.MoveDown Unit:=wdParagraph, Count:=1
    Selection.MoveUp Unit:=wdParagraph, Count:=2
    Selection.MoveDown Unit:=wdParagraph, Count:=2
    Selection.GoTo What:=wdGoToBookmark, _
        Name:="Move_Paragraph_Temp"
End Sub





If chkReturnToPreviousPosition = True Then
    With ActiveDocument.Bookmarks
        .Add Range:=Selection.Range, Name:=" Move_Paragraph_Temp"
    End With
End If




If optUpOne = True Then
    Selection.MoveUp Unit:=wdParagraph, Count:=1
ElseIf optUpTwo = True Then
    Selection.MoveUp Unit:=wdParagraph, Count:=2
ElseIf optDownOne = True Then
    Selection.MoveDown Unit:=wdParagraph, Count:=1
Else
    Selection.MoveDown Unit:=wdParagraph, Count:=2
End If
Selection.Paste



If chkReturnToPreviousPosition = True Then
    Selection.GoTo What:=wdGoToBookmark, _
        Name:=" Move_Paragraph_Temp"
    ActiveDocument.Bookmarks("Move_Paragraph_Temp").Delete
End If




Private Sub cmdOK_Click()
    frmMoveParagraph.Hide
    Unload frmMoveParagraph
    If chkReturnToPreviousPosition = True Then
        With ActiveDocument.Bookmarks
            .Add Range:=Selection.Range, _
                Name:="Move_Paragraph_Temp"
        End With
    End If
    Selection.Extend
    Selection.Extend
    Selection.Extend
    Selection.Extend
    Selection.Cut
    If optUpOne = True Then
        Selection.MoveUp Unit:=wdParagraph, Count:=1
    ElseIf optUpTwo = True Then
    Selection.MoveUp Unit:=wdParagraph, Count:=2
    ElseIf optDownOne = True Then
        Selection.MoveDown Unit:=wdParagraph, Count:=1
    Else
        Selection.MoveDown Unit:=wdParagraph, Count:=2
    End If
    Selection.Paste
    If chkReturnToPreviousPosition = True Then
        Selection.GoTo What:=wdGoToBookmark, _
            Name:="Move_Paragraph_Temp"
        ActiveDocument.Bookmarks("Move_Paragraph_Temp").Delete
    End If
End Sub






Option Base 1

Private Sub UserForm_Initialize()

    Dim strFileArray() As String
    Dim strFFile As String
    Dim intCount As Integer

    strFFile = Dir(c:\transfer\spreads\*.xlsb)
    intCount = 1

    Do While strFFile <> ""
        If strFFile <> "." And strFFile <> ".." Then
            ReDim Preserve strFileArray(intCount)
            strFileArray(intCount) = strFFile
            intCount = intCount + 1
            strFFile = Dir()
        End If
    Loop

    lstFiles.List() = strFileArray

End Sub

Private Sub cmdCancel_Click()
    Me.Hide
    Unload Me
End Sub

Private Sub cmdOpen_Click()
    Me.Hide
    If lstFiles.Value <> "" Then Workbooks.Open _
        Name:="c:\transfer\spreads" & lstFiles.Value
    Unload Me
End Sub






With Dialogs(wdDialogFormatFont)
    .DefaultTab = wdDialogFormatFontTabCharacterSpacing
    .Show
End With




If Documents.Count = 0 Then
    Proceed = MsgBox("Nie otwarto adnego dokumentu." _
        & vbCr & vbCr & _
        "Otwrz dokument do wykorzystania w procedurze.", _
        vbOKCancel + vbExclamation, "Raport formatowania")
    If Proceed = vbOK Then
        Dialogs(wdDialogFileOpen).Show
        If Documents.Count = 0 Then End
    Else
        End
    End If
End If
' tutaj reszta procedury




With Dialogs(wdDialogFileSaveAs)
    .Name = "Prbka farby tej"
    .Show
End With




With Dialogs(wdDialogToolsOptions)
    .DefaultTab = wdDialogToolsOptionsTabUserInfo
    .Show (10000)
End With




Rozdzia 15.


Private Sub UserForm_Initialize()
   frmInventories.Height = 120
End Sub

Private Sub cmdMore_Click()
   If cmdMore.Caption = "<<Mniej" Then
       cmdMore.Caption = "Wicej>>"
       cmdMore.Accelerator = "W"
       frmInventories.Height = 160
   Else
       frmInventories.Height = 300
       cmdMore.Caption = "<<Mniej"
       cmdMore.Accelerator = "M"
       fraOptions.Enabled = True
   End If
 End Sub

 Private Sub chkArtNames_Click()
     If chkArtNames = True Then
         optFromDocument.Enabled = True
         optFromDocument = True
         optAutoNames.Enabled = True
     Else
         optFromDocument.Enabled = False
         optFromDocument = False
         optAutoNames.Enabled = False
         optAutoNames = False
    End If
 End Sub

 Private Sub cmdOK_Click()
     frmInventories.Hide
     Unload frmInventories
     'tutaj tworzenie zestawie
 End Sub

 Private Sub cmdCancel_Click()
     End
 End Sub




Private Sub cmbSelectEmployee_Change()
  lblEmployeeName = cmbSelectEmployee.Text
  fraStep2.Enabled = True
  lblInstructions = "Wpisz tekst w polu tekstowym w ramce Krok 2. " & _
    "Na przykad moesz zamieci krtk informacj biograficzn " & _
    "na temat pracownika, dane dotyczce jego stanowiska " & _
    "lub Twoje oczekiwania co do jego wkadu w rozwj firmy."
  cmdClearEmployeeName.Enabled = True
End Sub





Private Sub tabSurfer_Change()
    If blnInitializing = False Then
        With ActiveWorkbook.Sheets(tabSurfer.Value + 1)
            ' zaadowanie zawartoci arkusza _
                odpowiadajcego wybranej zakadce
            .Activate
             txtFirstName.Text = .Cells(1, 2).Text
             txtInitial.Text = .Cells(2, 2).Text
             txtLastName.Text = .Cells(3, 2).Text
             txtAddress1.Text = .Cells(4, 2).Text
             txtAddress2.Text = .Cells(5, 2).Text
             txtCity.Text = .Cells(6, 2).Text
             txtState.Text = .Cells(7, 2)
             txtZip.Text = .Cells(8, 2).Text
             txtHomeArea.Text = .Cells(9, 2).Text
             txtHomePhone.Text = .Cells(10, 2).Text
             txtWorkArea.Text = .Cells(11, 2).Text
             txtWorkPhone.Text = .Cells(12, 2).Text
             txtWorkExtension.Text = .Cells(13, 2).Text
             txtEmail.Text = .Cells(14, 2).Text
         End With
     End If
 End Sub




Private Sub UserForm_QueryClose(Cancel As Integer, _
    CloseMode As Integer)
    'upewnij si, e uytkownik chce zamkn formularz, 
    'jeli wprowadzi do niego informacje
    Select Case CloseMode
        Case 0
            'uytkownik klikn przycisk Zamknij lub wywoa instrukcja Unload
            'jeli pole tekstowe zawiera wicej ni 5 znakw, zapytaj czy chce zapisa zmiany
            If Len(txtDescription.Text) > 5 Then
                If MsgBox("Pole Opis zawiera " & _
                    "znaczn ilo tekstu." & vbCr & _
                    "Czy chcesz zapisa ten tekst?", vbYesNo + _
                    vbQuestion, "Zamknij formularz") <> 0 Then
                    Documents.Add
                    Selection.TypeText txtDescription.Text
                    ActiveDocument.SaveAs _
                        "c:\temp\Temporary Description.docm"
                   MsgBox "Zawarto pola tekstowego Opis " & _
                       "zostaa zapisana w pliku " & _
                       "c:\temp\Temporary Description.docm.", _
                       vbOKOnly + vbInformation, _
                       "Zapisano dane formularza "
                End If
            End If
End Sub



Private Sub cmdWidenForm_Click()
     With frmResize
         If .Width < 451 Then
             .Width = .Width + 50
             If cmdNarrowForm.Enabled = False Then _
                 cmdNarrowForm.Enabled = True
             If .Width > 451 Then _
                  cmdWidenForm.Enabled = False
         End If
     End With
End Sub

 Private Sub cmdNarrowForm_Click()
     With frmResize
         If .Width > 240 Then
             .Width = .Width - 50
             If cmdWidenForm.Enabled = False Then _
                 cmdWidenForm.Enabled = True
             If .Width < 270 Then _
                  cmdNarrowForm.Enabled = False
         End If
     End With
 End Sub

 Private Sub cmdClose_Click()
     Unload Me
 End Sub

 Private Sub UserForm_Resize()
     txt1.Width = frmResize.Width - 30
 End Sub





Private Sub cmbZoom_Change()
'change the size of the controls:
    frmEventsDemo.Zoom = cmbZoom.Value
End Sub


Private Sub UserForm_Zoom(Percent As Integer)
' change the size of the form itself:
    frmEventsDemo.Width = 300 * cmbZoom.Value / 100
    frmEventsDemo.Height = 350 * cmbZoom.Value / 100
End Sub


Private Sub cmdAddControl_click()
    Dim opt1 As OptionButton
    Dim opt2 As OptionButton
    Dim opt3 As OptionButton
    Set opt1 = fraOptions.Controls.Add("Forms.OptionButton.1")
    Set opt2 = fraOptions.Controls.Add("Forms.OptionButton.1")
    Set opt3 = fraOptions.Controls.Add("Forms.OptionButton.1")
    With opt1
        .Left = 10
        .Top = 10
        .Name = "optDomestic"
        .Caption = "Domestic"
        .AutoSize = True
        .Accelerator = "D"
    End With
    'tutaj naley ustawi waciwoci dla kontrolek opt2 i opt3
End Sub

Private Sub fraOptions_AddControl(ByVal Control As MSForms.Control)
    MsgBox "Ramka zawiera teraz " & _
        fraOptions.Controls.Count & " kontrolek."
End Sub


Private Sub CommandButton1_Click()
    MsgBox "Zdarzenie Click"
End Sub

Private Sub CommandButton1_DblClick _
    (ByVal Cancel As MSForms.ReturnBoolean)
    MsgBox "Zdarzenie DblClick"
End Sub

Private strMess As String
Private Sub CommandButton1_Click()
    strMess = "Zdarzenie Click" & vbCr
End Sub

Private Sub CommandButton1_DblClick _
    (ByVal Cancel As MSForms.ReturnBoolean)
    strMessage = strMessage & "Zdarzenie DblClick"
    MsgBox strMessage
End Sub


Rozdzia 16.


Sub Applying_Arial_Font()
'
'Makro Applying_Arial_Font
'Stosuje czcionk Arial do zaznaczonego tekstu
'
    With Selection.Font
        .Name = "Arial"
        .Size = 13
        .Bold = False
        .Italic = False
        .Underline = wdUnderlineNone
        .UnderlineColor = wdColorAutomatic
        .StrikeThrough = False
        .DoubleStrikeThrough = False
        .Outline = False
        .Emboss = False
        .Shadow = False
        .Hidden = False
        .SmallCaps = False
        .AllCaps = False
        .Color = wdColorAutomatic
        .Engrave = False
        .Superscript = False
        .Subscript = False
        .Spacing = 0
        .Scaling = 100
        .Position = 0
        .Kerning = 0
        .Animation = wdAnimationNone
    End With
End Sub

Sub Stripped_Down_Procedure_Applying_Arial_Font()
    Selection.Font.Name = "Arial"
End Sub



With ActiveDocument.Paragraphs(1)
    .Range.Font.Bold = True
    .Range.Font.Name = "Times New Roman"
    .LineSpacingRule = wdLineSpaceSingle
    .Borders(1).LineStyle = wdLineStyleDouble
    .Borders(1).ColorIndex = wdBlue
End With



With ActiveDocument.Paragraphs(1)
    With .Range.Font
        .Bold = True
        .Name = "Times New Roman"
    End With
    .LineSpacingRule = wdLineSpaceSingle
    With .Borders(1)
        .LineStyle = wdLineStyleDouble
        .ColorIndex = wdBlue
    End With
End With


With ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary) _
    .Range.Words(1)
    .Bold = True
End With


With ActiveDocument
    With .Sections(1)
        With .Headers(wdHeaderFooterPrimary)
            With .Range
                With .Words(1)
                    With .Font
                        .Italic = True
                        .Bold = False
                        .Color = wdColorBlack
                    End With
                End With
            End With
        End With
    End With
End With


With ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range. _
    Words(1).Font
    .Italic = True
    .Bold = False
    .Color = wdColorBlack
End With




Sub Create_Rejection_Letter

    Dim strApplicantFirst As String, strApplicantInitial As String, _
        strApplicantLast As String, strApplicantTitle As String
    Dim strJobTitle As String
    Dim dteDateApplied As Date, dteDateInterviewed As Date
    Dim blnExperience As Boolean

    strApplicantFirst = "Shirley"
    strApplicantInitial = "P"
    strApplicantLast = "McKorley"
]


If MsgBox("Dokument nie zawiera tekstu." & vbCr & vbCr _
    & "Kliknij przycisk Tak, aby kontynuowa formatowanie dokumentu." & _
    " Kliknij przycisk Nie, aby anulowa procedur.", _
    vbYesNo & vbQuestion, _
    "Bd wyboru dokumentu: Anulowa procedur?") Then


Dim strMsg As String
Dim strTBar As String
strMsg = "The document contains no text." & vbCr & vbCr
strMsg = _
strMsg & "Kliknij przycisk Tak, aby kontynuowa formatowanie dokumentu."
strMsg = strMsg & "Kliknij przycisk Nie, aby anulowa procedur."
strTBar = "Bd wyboru dokumentu: Anulowa procedur?"
If MsgBox(strMsg, vbYesNo & vbQuestion, strTBar) Then


Sub GetCustomerInfo()
    Dim strCustName As String, strCustCity As String, _
        strCustPhone As String
    ' Pobierz wartoci strCustName, strCustCity, strCustPhone z bazy danych
    CreateCustomer strCustName, strCustCity, strCustPhone
End Sub

Sub CreateCustomer(ByRef strCName As String, _
    ByRef strCCity As String, ByVal strCPhone As String)
    Dim strCustomer As String
    strCustomer = strCName & vbTab & strCCity _
        & vbTab & strCPhone
    'tutaj podejmij dziaania z cigiem strCustomer
End Sub




Sub FindTotalCost()

Dim OriginalCost, TotalCost ' deklaracja dwch zmiennych typu Variant
OriginalCost = 155 'ten sweter jest drogi

TotalCost = AddTax(OriginalCost) 'wywoanie funkcji AddTax
MsgBox TotalCost 'wywietl czn cen, w tym 7% VAT


End Sub

Function AddTax(SubTotal)

AddTax = SubTotal * 1.07 'wykonaj obliczenia i przypisz wynik
                         'do nazwy funkcji tak, by zosta zwrcony na zewntrz

End Function



Private strPassMe As String

Sub PassingInfo()
    strPassMe = "Witaj."
    PassingInfoBack
    MsgBox strPassMe
End Sub

Sub PassingInfoBack()
    strPassMe = strPassMe & " Jak si masz?"
End Sub


Option Explicit

Const BookName = "Projekt Ksika"
Dim BookTitle As String
Dim BookAuthor As String
Dim BookPages As Integer
Dim BookPrice As Currency
Dim BookPublicationDate As Date

 Public Property Let Title(strT As String)
     BookTitle = strT
 End Property

 Public Property Get Title() As String
     Title = BookTitle
 End Property

 Public Property Let Author(strA As String)
     BookAuthor = strA
 End Property

 Public Property Get Author() As String
     Author = BookAuthor
 End Property

 Public Property Let Pages(intPages As Integer)
     BookPages = intPages
 End Property

 Public Property Get Pages() As Integer
     Pages = BookPages
 End Property

 Public Property Let Price(curP As Currency)
     BookPrice = curP
 End Property

 Public Property Get Price() As Currency
     Price = BookPrice
 End Property

 Public Property Let PublicationDate(dtePD As Date)
     BookPublicationDate = dtePD
 End Property

 Public Property Get PublicationDate() As Date
     PublicationDate = BookPublicationDate
 End Property






Sub ShowInfo()
    Dim strM As String
    strM = "Tytu:" & vbTab & BookTitle & vbCr
    strM = strM & "Autor:" & vbTab & BookAuthor & vbCr
    strM = strM & "Liczba stron:" & vbTab & BookPages & vbCr
    strM = strM & "Cena:" & vbTab & "$" & BookPrice & vbCr
    strM = strM & "Data:" & vbTab & Me.PublicationDate & vbCr
         MsgBox strM, vbOKOnly + vbInformation, BookName _
         & " Informacje"
End Sub





Sub Class_Test()

    Dim myBook As New Book

    myBook.Title = "Mastering VBA for Microsoft Office 2019"
    myBook.Price = 50.00
    myBook.Author = "Richard Mansfield"
    myBook.Pages = 880
    myBook.PublicationDate = #8/17/2019#

    myBook.ShowInfo

End Sub



Rozdzia 17.

Sub See_All_Workbook_Names()
    Dim oBook As Workbook
    For Each oBook In Workbooks
        Debug.Print oBook.FullName
    Next
End Sub



For i = 1 To 1500
  If i > 1200 Then
    MsgBox (i)
    Exit For
  End If
Next



Sub ErrorDemo()
    On Error GoTo ErrorHandler
    'tutaj znajd si zwyke instrukcje

Exit Sub
ErrorHandler:
           'tutaj bd instrukcje obsugi bdw
End Sub



Sub ErrorDemo2()
    On Error GoTo ErrorHandler1
    'tutaj instrukcje
    On Error GoTo ErrorHandler2
    'tutaj instrukcje
    Exit Sub
ErrorHandler1:
    'tutaj instrukcje pierwszego bloku obsugi bdw
ErrorHandler2:
    'tutaj instrukcje drugiego bloku obsugi bdw
End Sub




Sub ErrorDemo3()
    On Error GoTo ErrorHandler
    'instrukcje, ktre mog spowodowa wystpienie bdu
    Exit Sub
ErrorHandler:
    'instrukcje, ktre obsuguj bd
End Sub





Sub ErrorDemo4()
    On Error GoTo ErrorHandler
    'instrukcje, ktre mog spowodowa wystpienie bdu
    GoTo SkipErrorHandler
ErrorHandler:
    'instrukcje, ktre obsuguj bd
SkipErrorHandler:
    'instrukcje
End Sub



Sub StyleError()

    On Error GoTo Handler

    Selection.Style = "Raport dla kierownictwa"

    'tutaj znajdzie si pozostaa cz procedury

    'kiedy sterowanie dotrze do tego miejsca, wyjd z procedury
    Exit Sub

Handler:

    If Err = 5834 Then
        ActiveDocument.Styles.Add _
            Name:="Raport dla kierownictwa", Type:=wdStyleTypeParagraph
        Resume
    End If

End Sub





Sub StyleError2()
    On Error GoTo Handler

    Selection.Style = "Raport dla kierownictwa"

   'tutaj znajdzie si pozostaa cz procedury

   'kiedy sterowanie dotrze do tego miejsca, wyjd z procedury
Exit Sub

Handler:
    Resume Next

End Sub




 Sub Handle_Error_Opening_File()

     Dim strFName As String

 StartHere:

      On Error GoTo ErrorHandler
      strFName = InputBox("Wpisz nazw pliku do otwarcia.", _
            "Otwieranie pliku")
      If strFName = "" Then End
      Documents.Open strFName
      Exit Sub

 ErrorHandler:

    If Err = 5174 Or Err = 5273 Then MsgBox _
          "Plik " & strFName & " nie istnieje." & vbCr & _
            "Wprowad nazw ponownie.", _
            vbOKOnly + vbCritical, "Bd pliku"
      Resume StartHere

 End Sub




Sub CancelKey_Example()
    Dim i As Long
    On Error GoTo EH
    Application.EnableCancelKey = xlErrorHandler
    For i = 1 To 100000000 'czasochonna ptla
        Application.StatusBar = i
    Next i
EH:
    If Err.Number = 18 Then
        If MsgBox("Czy chcesz zatrzyma procedur?" _
            & vbCr & vbCr & "Jeli nie, przesta naciska Ctrl+Break!", _
            vbYesNo + vbCritical, "Wykryto prb przerwania procedury") = vbYes Then End
    End If
End Sub




' do tego punktu przerywane dziaania jest dozwolone
Application.EnableCancelKey = wdCancelDisabled
For i = 1 to LastFile
     SourceFile = Source & "\Section" & i
    DestFile = Destination & "\Section" & i
    Name SourceFile As DestFile
Next i
Application.EnableCancelKey = wdCancelInterrupt
'za tym punktem przerywane dziaania jest dozwolone


Rozdzia 18.


Dim CaseStatus As Boolean 'sprawdzanie wielkoci liter jest wczone lub wyczone
CaseStatus = Selection.Find.MatchCase 'zapisanie ustawie uytkownika
Selection.Find.MatchCase = True 'w naszym makro musi by rozrniana wielko liter
' uruchomienie instrukcji w makro
Selection.Find.MatchCase = CaseStatus 'przywrcenie ustawie uytkownika




Sub SaveAndRestoreCursor()

'zapisanie biecej lokalizacji kursora w zakadce
   ActiveDocument.Bookmarks.Add Name:="OriginalInsertionPoint", _
   Range:=Selection.Range

'przejcie o osiem wierszy w d
   Selection.MoveDown Unit:=wdLine, Count:=8

   MsgBox "przeniesiono tutaj (popatrz na wiersz z kursorem, zosta przeniesiony o 8 wierszy 
w d od miejsca, w ktrym by wczeniej.)"

' pobierz zapisan zakadk i przejd do niej
   Selection.GoTo what:=wdGoToBookmark, Name:="OriginalInsertionPoint"

MsgBox "Teraz wiersz z kursorem przywrcono do miejsca, w ktrym by w chwili, gdy to makro zaczo dziaa)"

' usu zakadk, aby nie pozostawia ladw

   ActiveDocument.Bookmarks("OriginalInsertionPoint").Delete
 End Sub





Sub Create_Log_File()

    Dim strDate As String
    Dim strPath As String
    Dim strCity(10) As String
    Dim strLogText As String
    Dim strLogName As String
    Dim strSummary As String
    Dim strFile As String
    Dim i As Integer

    On Error GoTo Crash

    strCity(1) = "Chicago"
    strCity(2) = "Toronto"
    strCity(3) = "New York"
    strCity(4) = "London"
    strCity(5) = "Lyons"
    strCity(6) = "Antwerp"
    strCity(7) = "Copenhagen"
    strCity(8) = "Krakow"
    strCity(9) = "Pinsk"
    strCity(10) = "Belgrade"

    strDate = Month(Date) & "-" & Day(Date) & "-" _
        & Year(Date)
    strPath = "f:\Daily Data\"
    strLogName = strPath & "Reports\Log for " _
        & strDate & ".docm"
    strSummary = strPath & "Reports\Summary for " _
        & strDate & ".docm"
    Documents.Add
    ActiveDocument.SaveAs strSummary

    For i = 1 To 10
        strFile = strPath & strCity(i) & " " & strDate & ".docm"
        If Dir(strFile) <> "" Then
            Documents.Open strFile
            Documents(strFile).Paragraphs(1).Range.Copy
            Documents(strFile).Close _
                SaveChanges:=wdDoNotSaveChanges
            With Documents(strSummary)
                Selection.EndKey Unit:=wdStory
                Selection.Paste
                .Save
            End With
            strLogText = strLogText & strCity(i) _
                & vbTab & "OK" & vbCr
        Else
            strLogText = strLogText & strCity(i) _
                & vbTab & "No file" & vbCr
        End If
    Next i

Crash:

    Documents.Add
    Selection.TypeText strLogText
    ActiveDocument.SaveAs strLogName
    Documents(strLogName).Close
    Documents(strSummary).Close

End Sub





If Workbooks.Count = 0 Then _
    MsgBox "Ta procedura nie bdzie dziaa bez " _
& "otwartego skoroszytu. Otwrz skoroszyt, a nastpnie ponownie uruchom procedur.", _
vbOKOnly +\ vbExclamation, _
"Nie otwarto skoroszytu"




Dim s As String
s = "c:\TempDir"

If Len(Dir(s, vbDirectory)) = 0 Then
    MkDir s
End If




Rozdzia 19.

Brak kodu



Rozdzia 20.


If Documents.Count = 0 Then
    If MsgBox("aden dokument nie jest otwarty." & vbCr & vbCr & _
        "Czy chcesz stworzy nowy, pusty dokument?", _
        vbYesNo + vbExclamation, "Brak otwartego dokumentu") = vbYes Then
        Documents.Add
    Else
        End
    End If
End If



Dim myDocument As Document
Set myDocument = ActiveDocument
With myDocument
    'tutaj inne dziaania
End With

Dim myDocument As Document
Set myDocument = ActiveDocument
If myDocument.Name = "CorrectFile.docx" Then
    'tutaj inne dziaania
End If





If Selection.Type = wdSelectionIP Then
    Selection.TypeText "Wstawiamy ten tekst."
End If








If Selection.StoryType <> wdMainTextStory Then
    MsgBox "Ten fragment nie naley do gwnego tekstu."
End If







Dim InitialCaps As Range
Set InitialCaps = ActiveDocument.Range _
(Start:=ActiveDocument.Words(1).Start, _
    End:=ActiveDocument.Words(3).End)
InitialCaps.Case = wdUpperCase





Dim blnTrackChangesOn As Boolean
blnTrackChangesOn = ActiveDocument.TrackRevisions
ActiveDocument.TrackRevisions = False
'tutaj mona napisa wicej kodu wykonywania dziaa
ActiveDocument.TrackRevisions = blnTrackChangesOn






Rozdzia 21.


With ActiveDocument.Content.Find
    .ClearFormatting
    .Replacement.ClearFormatting
End With



With Documents("Example.docm").Content.Find
    .ClearFormatting
    .Font.Bold = True
    With .Replacement
        .ClearFormatting
        .Font.Bold = False
        .Font.Italic = True
    End With
    .Execute FindText:= "", ReplaceWith:= "", _
        Format:=True, Replace:=wdReplaceAll
End With





Dim cSection As Section
With ActiveDocument
    For Each cSection In .Sections
        cHeader = cSection.Headers(wdHeaderFooterEvenPages)
        If Not cSection.Headers(wdHeaderFooterEvenPages).Exists Then
            cSection.PageSetup.OddAndEvenPagesHeaderFooter = True
            cSection.Headers(wdHeaderFooterEvenPages).Range.Text _
                = "Sekcja " & cSection.Index & " of " & .FullName
            cSection.Headers(wdHeaderFooterEvenPages).Range. _
                Style = "Stopka"
        End If
    Next cSection
End With






Sub AddPageNumbersToAllHeadersAndSections()
    Dim cHeader As HeaderFooter, cSection As Section
    With Documents("Headers and Footers.docm")
        For Each cSection In .Sections
            For Each cHeader In cSection.Headers
                cSection.Headers(wdHeaderFooterPrimary).PageNumbers.Add _
                PageNumberAlignment:=wdAlignPageNumberRight, FirstPage:=True
            Next cHeader
        Next cSection
    End With
End Sub






Sub RemovePageNumbersFromCurrentSection()
    Dim ThisHeader As HeaderFooter
    Dim ThisPageNumber As PageNumber
    With Selection.Sections(1)
        For Each ThisHeader In .Headers
            For Each ThisPageNumber In ThisHeader.PageNumbers
                ThisPageNumber.Delete
            Next ThisPageNumber
        Next ThisHeader
    End With
End Sub





With ActiveDocument.Sections(4).Headers(wdHeaderFooterPrimary)
    If .PageNumbers.StartingNumber = 0 Then
        .PageNumbers.RestartNumberingAtSection = True
        .PageNumbers.StartingNumber = 55
    End If
End With




With ActiveDocument.Sections(4).Headers(wdHeaderFooterPrimary) _
    .PageNumbers
    .IncludeChapterNumber = True
    .ChapterPageSeparator = wdSeparatorEnDash
End With



ActiveDocument.Sections(4).Headers(wdHeaderFooterPrimary) _
    .PageNumbers(1).Select
    With Selection.Font
        .Name = "Impact"
        .Size = 22
        .Bold = True
    End With


ActiveDocument.Sections(ActiveDocument.Sections.Count) _
    .Headers(wdHeaderFooterPrimary).Range.Select
With Selection
    .Paragraphs(1).Alignment = wdAlignParagraphCenter
    .TypeText Text:="Page "
    .Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "PAGE ", PreserveFormatting:=True
    .TypeText Text:=" z "
    .Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "NUMPAGES ", PreserveFormatting:=True
End With




With Documents("Planning.docm").PageSetup
    .PaperSize = wdPaperLetter
    .Orientation = wdOrientPortrait
    .TopMargin = 1
    .BottomMargin = 1
    .LeftMargin = 1
    .RightMargin = 1.5
    .MirrorMargins = True
End With




Dim myWin As Window, myDoc As String
myDoc = ActiveDocument.Name
For Each myWin In Windows
    If myWin.Document = myDoc Then _
        If myWin.WindowNumber <> 1 Then myWin.Close
Next myWin





With Documents("Example.docm").Windows(1)
    If .WindowState = wdWindowStateMinimize Then _
       .WindowState = wdWindowStateMaximize
End With




Dim rngFirstList As Range
Set rngFirstList = ActiveDocument.Lists(1).Range
ActiveDocument.Windows(1).ScrollIntoView Obj:=rngFirstList,
   Start:=False
rngFirstList.Select
Selection.Collapse Direction:=wdCollapseEnd
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdMove






With Documents("Sample.docm").Windows(1).View
    .Type = wdPrintView
    With .Zoom
        .PageColumns = 3
        .PageRows = 2
    End With
End With









Set myTable = Selection.ConvertToTable(wdSeparateByCommas, _
    Selection.Paragraphs.Count, 5, , , , , , , , , , , True, _
    wdAutoFitContent, wdWord9TableBehavior)







Dim curSel
With Documents("Communications.docm")
    If Selection.Type <> wdSelectionIP Then
        Set curSel = Selection.Range
        Selection.Collapse Direction:=wdCollapseStart
    End If
    If Selection.Information(wdAtEndOfRowMarker) = True Then
        Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdMove
    Else
        If curSel <> "" Then curSel.Select
        Set curSel = Nothing
    End If
End With








With testRange
    If .Information(wdStartOfRangeColumnNumber) <> _
        .Information(wdEndOfRangeColumnNumber) Then _
        .Tables(1).Columns(.Information _
        (wdEndOfRangeColumnNumber)).Delete
End With








With ActiveDocument.Tables(1)
    .Select
    If .Columns.Count < 5 Then
        Do Until .Columns.Count = 5
            .Columns.Add BeforeColumn:=.Columns(.Columns.Count)
        Loop
     End If
End With





With Selection.Tables(1).Rows(1)
    .Cells(1).Range.Text = "Przykadowy tekst w pierwszej komrce."
    .Cells(2).Range.Text = "Przykadowy tekst w pierwszej komrce."
    .Cells(3).Range.Text = "Przykadowy tekst w trzeciej komrce."
End With







With Selection
    If .Columns.Count > 1 And .Rows.Count > 1 Then
        MsgBox "Prosz zaznaczy komrki tylko w jednym wierszu" _
            & "lub tylko w jednej kolumnie."
        End
    Else
        If .Cells.Count > 1 Then
            If .Columns.Count > 1 Then
                .Cells.Delete ShiftCells:=wdDeleteCellsShiftUp
            Else
                .Cells.Delete ShiftCells:=wdDeleteCellsShiftLeft
            End If
        Else
            .Cells.Delete ShiftCells:=wdDeleteCellsShiftLeft
        End If
    End If
End With










Dim exTable As Range
Set exTable = Documents("Cleveland Report.docm").Tables(1). _
    ConvertToText(Separator:=wdSeparateByParagraphs)
exTable.Copy
Documents.Add
Selection.Paste











Sub Untable()

On Error Resume Next

   Selection.Rows.ConvertToText Separator:=wdSeparateByCommas, NestedTables:= _
     True
   Selection.MoveDown Unit:=wdLine, Count:=1

If Err Then MsgBox "Nie zaznaczono tabeli."

End Sub




Rozdzia 22.

Sub MVBA_New_Workbook_with_12_Sheets()
    Dim mySiNW As Integer
    mySiNW = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 12
    Workbooks.Add
    Application.SheetsInNewWorkbook = mySiNW
End Sub




Sub Save_All_Workbooks()
    Dim myWorkbook As Workbook
    For Each myWorkbook In Workbooks
        myWorkbook.Save
    Next myWorkbook
End Sub






With Workbooks("Brainstorming.xlsx")
    If MultiUserEditing = False Then
        .SaveAs Filename:=.FullName, AccessMode:=xlShared
    End If
End With





If ActiveWorkbook Is Nothing Then
    MsgBox "Otwrz skoroszyt i kliknij w nim przed uruchomieniem tego makra." _ 
       & vbCr & vbCr & "Makro zakoczy dziaanie.", _
       vbOKOnly + vbExclamation, "Brak otwartego skoroszytu"
    End
End If



Dim myWorkbook As Workbooks
Set myWorkbook = ActiveWorkbook
With myWorkbook
    ' tutaj inne dziaania
End With

Set myActiveCell = ActiveCell
    Set myActiveWorksheet = ActiveSheet
    Set myActiveWorkbook = ActiveWorkbook

    ' tutaj inne dziaania

    myActiveWorkbook.Activate
    myActiveWorksheet.Activate
    myActiveCell.Activate




With ActiveCell.CurrentRegion.Font
    .Name = "Times New Roman"
    .Size = 12
    .Bold = False
    .Italic = False
End With


With ActiveCell.CurrentRegion.Font
    .Name = "Times New Roman"
    .Size = 12
    .Bold = False
    .Italic = False
End With



Dim myMacroRange As Range
Set myMacroRange = ActiveWindow.RangeSelection
With myMacroRange
    'tutaj wykonaj dziaania na zakresie
End With
myMacroRange.Activate


With Range("myRange")
    .RowHeight = 20
    .Font.Name = "Arial"
    .Font.Size = "16"
End With


Dim varAutoCalculation As Variant
varAutoCalculation = Application.Calculation
Application.Calculation = xlCalculationManual
'enter the data here
Application.Calculation = xlCalculationAutomatic



Dim myMax As Long
With Application.RecentFiles
    myMax = .Maximum 'zapisz obecnie obowizujce preferencje uytkownika
    .Maximum = 0
    .Maximum = myMax
End With



Rozdzia 23.



Sub test()

Dim myChartObject As ChartObject
Dim MyChart As Chart

Set myChartObject = ActiveSheet.ChartObjects.Add(Left:=100, Top:=100, _
    Width:=400, Height:=300)

Set MyChart = myChartObject.Chart
MyChart.ChartType = xlConeBarStacked

MyChart.SeriesCollection.Add _
 Source:=ActiveSheet.Range("A4:K4"), Rowcol:=xlRows

End Sub





With myChart.Legend
    .HasLegend = True
    .Font.Size = 16
    .Font.Name = "Arial"
End With



With MyChart
   With .Axes(Type:=xlCategory, AxisGroup:=xlPrimary)
.HasTitle = True
      .AxisTitle.Text = "Lata"
      .AxisTitle.Font.Name = "Times New Roman"
      .AxisTitle.Font.Size = 12
      .HasMajorGridlines = True
      .HasMinorGridlines = False
    End With

End With



Dim myWindow1 As Window, myWindow2 As Window
Set myWindow1 = ActiveWindow
Set myWindow2 = myWindow1.NewWindow
With myWindow1
    .WindowState = xlNormal
    .Top = 0
    .Left = 0
    .Height = Application.UsableHeight
    .Width = Application.UsableWidth * 0.25
End With
With myWindow2
    .WindowState = xlNormal
    .Top = 0
    .Left = (Application.UsableWidth * 0.25) + 1
    .Height = Application.UsableHeight
    .Width = Application.UsableWidth * 0.75
End With




    With Application.FindFormat.Font
        .Name = "Arial"
        .Size = "12"
        .Bold = True
    End With
    With Application.ReplaceFormat.Font
        .Name = "Arial Black"
        .Bold = False
    End With
    Cells.Replace What:="5", Replacement:="5", LookAt:=xlPart, SearchOrder _
        :=xlByColumns, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True




Sub AutoShapes()

    ActiveSheet.Shapes.AddShape(msoShapeExplosion2, 425, 145, 86, 101).Select
    ActiveSheet.Shapes.AddShape(msoShapeExplosion1, 265, 224, 190, 190).Select

End Sub



Rozdzia 24.

If ActivePresentation.Path = "" Then
    ActivePresentation.SaveAs FileName:="z:\public\presentations\Corporate.pptm"
Else
    ActivePresentation.Save
End If




Sub Save_All_Presentations()
    Dim myPresentation As Presentation
    For Each myPresentation In Presentations
        If myPresentation.Path <> "" Then myPresentation.Save
    Next myPresentation
End Sub




With ActivePresentation
    If .Path = "" Then
        MsgBox "Zapisz t prezentacj.", vbOKOnly
    Else
        .Save
        For Each myWindow In Windows
            .Close
        Next myWindow
    End If
End With




Dim TargetSlide As Long
TargetSlide = ActivePresentation.Slides.Add(Index:=5, _
    Layout:=ppLayoutFourObjects).SlideID
Presentations("Corporate.pptm").Slides.InsertFromFile _
    FileName:="Z:\Transfer\Presentations\Handbook.pptm", Index:=3
ActivePresentation.Slides.FindBySlideID(TargetSlide).ApplyTemplate _
    FileName:="C:\Program Files\Microsoft Office\Templates\Presentation
    Designs\Brain Blitz.potm


With Presentations("Corporate.pptm").Slides(4)
    .FollowMasterBackground = msoFalse
    .DisplayMasterShapes = msoFalse
    With .Background
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
        .Fill.BackColor.SchemeColor = ppAccent1
        .Fill.UserPicture "C:\Sample Pictures\Winter.jpg"
    End With
End With





With ActivePresentation.Slides(2)
    With .SlideShowTransition
        .EntryEffect = ppEffectFade
        .Speed = ppTransitionSpeedMedium
        .AdvanceOnClick = msoTrue
        .AdvanceOnTime = msoTrue
        .AdvanceTime = 30
        .SoundEffect.ImportFromFile _
            FileName:="d:\Sounds\Crescendo.wav"
        .LoopSoundUntilNext = msoFalse
    End With
End With



With myPresentation
    If .HasTitleMaster Then
        With .TitleMaster.HeadersFooters.DateAndTime
            .Visible = msoTrue
            .Format = ppDateTimedMMMyy
            .UseFormat = msoTrue
        End With
    End If
End With




With ActivePresentation.HandoutMaster.Background
    .Fill.ForeColor.RGB = RGB(255, 255, 255)
    .Fill.BackColor.SchemeColor = ppAccent1
    .Fill.UserPicture "d:\igrafx\dawn.jpg"
End With









Rozdzia 25.

Sub test()

ActivePresentation.Slides(ActivePresentation.Slides.Count) _
    .Shapes.AddShape Type:=msoShapeBentUpArrow, Left:=575, Top:=10, _
    Width:=150, Height:=75

End Sub



ActivePresentation.Slides(3).Shapes.AddTextEffect _
   PresetTextEffect:=msoTextEffect14, _
        Text:="Questions" + Chr$(CharCode:=13) + _
        "&" + Chr$(CharCode:=13) + "Answers", _
        FontName:="Garamond", FontSize:=54, FontBold:=msoTrue, _
        FontItalic:=msoFalse, Left:=230, Top:=125




Dim myTextBox As Shape

With ActivePresentation.Slides(2)
    Set myTextBox = .Shapes.AddTextbox _
        (Orientation:=msoTextOrientationHorizontal, Left:=100, Top:=50, _
        Width:=400, Height:=100)
    myTextBox.TextFrame.TextRange.Text = "Corrective Lenses"
End With




With ActivePresentation.Slides(1).Shapes(1)
    .Left = 200
    .Top = 100
    .Width = 300
    .Height = 200
End With




With ActivePresentation.Slides(3).Shapes(1)
    .IncrementLeft Increment:=-100
    .IncrementTop Increment:=200
    .IncrementRotation Increment:=-90
End With




Sub Test()

Dim myPresentation As Presentation
Set myPresentation = Presentations(1)

myPresentation.Slides(4).Shapes(1).TextFrame.TextRange.Text _
    = "Spotkanie w sprawie planu strategicznego"

End Sub




Dim mySlide As Slide
Set mySlide = Presentations(1).Slides(2)

With mySlide.Shapes(2).TextFrame.TextRange.ParagraphFormat
    .Alignment = ppAlignLeft
    .LineRuleAfter = msoFalse
    .SpaceAfter = 18
    .LineRuleBefore = msoFalse
    .SpaceBefore = 18
    .LineRuleWithin = msoFalse
    .SpaceWithin = 12
End With




With mySlide.Shapes(1).TextFrame.TextRange.ParagraphFormat.Bullet
    .Type = ppBulletUnnumbered
    .Character = 254
    With .Font
        .Name = "Wingdings"
        .Size = 44
        .Color = RGB(255, 255, 255)
    End With
End With




With mySlide.Shapes(1).TextFrame.TextRange.ParagraphFormat.Bullet
    .Type = ppBulletPicture
    .Picture Picture:="z:\Public\Pictures\Face1.png"
End With




Dim mySlide As Slide
Set mySlide = Presentations(1).Slides(2)

With mySlide.Shapes(1).AnimationSettings
    .EntryEffect = ppEffectFlyFromRight
    .AdvanceMode = ppAdvanceOnClick
    .SoundEffect.ImportFromFile FileName:="D:\Media\Whistle4.wav"
    .TextLevelEffect = ppAnimateByFirstLevel
    .TextUnitEffect = ppAnimateByParagraph
End With




Sub SetFooter()

Dim objPresTation As Presentation
Set objPresTation = Application.ActivePresentation

With objPresTation.Slides(2).HeadersFooters.DateAndTime

    .UseFormat = True

    .Format = ppDateTimeddddMMMMddyyyy

End With


End Sub




With ActivePresentation.SlideShowSettings
    .LoopUntilStopped = msoCTrue
    .AdvanceMode = ppSlideShowUseSlideTimings
    .ShowType = ppShowTypeKiosk
    .Run
End With



With Presentations("Korporacja.pptm").SlideShowSettings
    .LoopUntilStopped = msoFalse
    .ShowType = ppShowTypeSpeaker
    .AdvanceMode = ppSlideShowManualAdvance
    With .Run
        .Height = 600
        .Width = 800
        .Left = 0
        .Top = 0
    End With
End With



Dim myArray(4) As Long
With Presentations("Corporate.pptm")
    myArray(1) = .Slides(2).SlideID
    myArray(2) = .Slides(4).SlideID
    myArray(3) = .Slides(5).SlideID
    myArray(4) = .Slides(10).SlideID
    .SlideShowSettings.NamedSlideShows.Add Name:="Krtki pokaz", _
         safeArrayOfSlideIDs:=myArray
End With




With Presentations("Korporacja.pptm").SlideShowSettings
    .RangeType = ppShowSlideRange
    .StartingSlide = 4
    .EndingSlide = 8
    .Run
End With





Rozdzia 26.



Sub List_All_NameSpace_Folders()
    Dim myNS As NameSpace
    Dim myFolder As MAPIFolder
    Dim mySubfolder As MAPIFolder
    Dim strFolderList As String

    strFolderList = "Obiekt NameSpace Outlooka zawiera nastpujce foldery:" _
        & vbCr & vbCr

    Set myNS = Application.GetNamespace("MAPI")
    With myNS
        For Each myFolder In myNS.Folders
            strFolderList = strFolderList & myFolder.Name & vbCr
            For Each mySubfolder In myFolder.Folders
                strFolderList = strFolderList & "*  " & mySubfolder.Name & vbCr
            Next mySubfolder
        Next myFolder

    End With
    MsgBox strFolderList, vbOKOnly + vbInformation, "Foldery w obiekcie NameSpace"

End Sub





If Not TypeName(ActiveWindow) = "Nothing" Then
    MsgBox "Aktywne okno to " & TypeName(ActiveWindow) & "."
End If




Sub MaxIt()

If TypeName(Application.ActiveInspector) = "Nothing" Then

    MsgBox "aden element nie jest teraz otwarty."
    End 'zamknicie makra

Else

Application.ActiveInspector.WindowState = olMaximized

End If

End Sub




Dim myMessage As MailItem
Set myMessage = Application.CreateItem(ItemType:=olMailItem)
With myMessage
    .To = "test@example.com"
    .Subject = "Testowa wiadomo"
    .Body = "To jest testowa wiadomo."
    .Display
End With





Dim myTask As TaskItem
Set myTask = Application.CreateItem(ItemType:=olTaskItem)
With myTask
    .Subject = "Zorganizuj spotkanie dotyczce przegldu projektu"
    .StartDate = Date
    .DueDate = Date + 7
    .ReminderSet = False
    .Save
End With




If TypeName(ActiveInspector) = "Nothing" Then
    MsgBox "Nie mona uruchomi tego makra, poniewa " & _
        "nie ma aktywnego okna.", vbOKOnly, "Nie mona uruchomi makra"
    End
Else
    If ActiveInspector.IsWordMail Then
        ActiveInspector.CurrentItem.SaveAs "c:\temp\message.doc"
    Else
        ActiveInspector.CurrentItem.SaveAs "c:\temp\message.rtf"
    End If
End If




Dim myMessage As Outlook.MailItem

Set myMessage = Application.CreateItem(olMailItem)

With myMessage
    .To = "petra_smith@ourbigcompany.com"
    .Subject = "Preparation for Review"
    .BodyFormat = olFormatHTML
    .HTMLBody = "Prosz wpadnij jutro i powi mi kilka minut " _
        & " na omwienie materiaw potrzebnych do przegldu projektu Darii."
    .Importance = olImportanceHigh
    .Display
End With








myMessage.Attachments.Add _
    Source:="Y:\Przykadowe dokumenty\Redukcja firmy.pptm", _
    Position:=1, DisplayName:="Prezentacja dotyczca redukcji"

With myMessage
    .To = "paulina_kowalska@naszafirma.com"
    .Subject = "Przygotowanie do przegldu"
    .HTMLBody = "Prosz wpadnij jutro i powi mi kilka minut " _
        & " na omwienie materiaw potrzebnych do przegldu projektu Darii."
    .BodyFormat = olFormatHTML
    .Importance = olImportanceHigh
    .Send
End With






Dim myAppointment As AppointmentItem
Set myAppointment = Application.CreateItem(ItemType:=olAppointmentItem)




Dim myAppointment As Outlook.AppointmentItem
Set myAppointment = Application.CreateItem(ItemType:=olAppointmentItem)
With myAppointment
    .Subject = "Stomatolog"
    .Body = "Dr Nowak" & vbCr & "Mickiewicza 32"
    .Start = Str(Date + 7) & " 2.30 PM"
    .End = Str(Date + 7) & " 3.30 PM"
    .BusyStatus = olBusy
    .Categories = "Osobiste"
    .ReminderMinutesBeforeStart = 30
    .ReminderSet = True
    .Save
End With







Dim myTask As TaskItem
Set myTask = Application.CreateItem(ItemType:=olTaskItem)
With myTask
    .Subject = "Utworzenie biznes planu"
    .Body = "Biznes plan musi obejmowa nastpne cztery lata." & _
        vbCr & vbCr & "Musi on zawiera szczegowy budet, " & _
        "plany kadrowe oraz analiz kosztw i korzyci."
    .DueDate = Str(Date + 28)
    .Status = olTaskInProgress
    .PercentComplete = 10
    .Companies = "Acme Poligloci Przemysowcy"
    .BillingInformation = "Sprzeda i marketing"
    .Importance = olImportanceHigh
    .Save
End With







Dim myTaskAssignment As TaskItem
Set myTaskAssignment = Application.CreateItem(ItemType:=olTaskItem)
With myTaskAssignment
    .Assign
    .Recipients.Add Name:="Piotr Nowakowski"
    .Subject = "Kup Bagietki na wito jedzenia"
    .Body = "Twoja kolej na dostarczenie bueczek na pitek."
    .Body = .Body & vbCr & vbCr & "Zapamitaj: ADNYCH pczkw."
    .DueDate = Str(Date + 3)
    .Send
End With










#If Win64 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongLong)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Sub AdvancedSearch()
  
 Dim objResults As Search
 Dim myFilter As String
 Dim SearchWhere As String
 Dim myTag As String
 Dim myResults As Results
 Dim strMessages As String
 Dim intCounter As Integer
 
'zastp sowo proces, w definicji zmiennej myFilter poniej, sowem, ktre moe wystpi kilka razy 
'w wierszach Temat wiadomoci w skrzynce odbiorczej Outlooka 

    myFilter = Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%proces%'"
 
 SearchWhere = "Inbox"
 myTag = "SubjectSearch"
 
 Set objResults = Outlook.AdvancedSearch(Scope:=SearchWhere, Filter:=myFilter, SearchSubFolders:=True, Tag:=myTag)
 Set myResults = objResults.Results

 'Aby uzyska wyniki, dostosuj odpowiednio to opnienie
 Sleep (3000)
 
strMessages = "Znaleziono cznie: " & myResults.Count & vbCr & vbCr
  
For intCounter = 1 To myResults.Count
        strMessages = strMessages & _
        myResults.Item(intCounter).SenderName & vbCr
Next intCounter

MsgBox strMessages, vbOKOnly, "Search Results"
 
End Sub






Rozdzia 27.



Private Sub Application_Startup()
    Dim myNoteItem As NoteItem
    Set myNoteItem = Application.CreateItem(ItemType:=olNoteItem)
    myNoteItem.Body = "Uruchom now kart czasow dla dzisiejszego dnia."
    myNoteItem.Display
End Sub



Private Sub Application_Quit()
    Dim strMessage As String
    Select Case Format(Date, "DD/MM/YYYY")
        Case "05/01/2019"
            strMessage = "Jutro jest wito Trzech Krli."
        Case "14/08/2019"
            strMessage = "Jutro jest wito Wojska Polskiego."
        Case "10/11/2019"
            strMessage = "Jutro jest wito Niepodlegoci."
        Case "02/05/2019"
            strMessage = "Jutro jest wito Konstytucji." & _
                       Case "30/04/2019"
            strMessage = "Jutro jest wito Pracy."
        'tutaj inne wita pastwowe 
    End Select

Msgbox "Nie ma wit w tym tygodniu."
If strMessage = "" Then Exit Sub

MsgBox strMessage, vbOKCancel + vbExclamation, "Nie zapomnij..."

End Sub




Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If Item.Subject = "" Then
        MsgBox "Dodaj temat wiadomoci przed jej wysaniem."
        Cancel = True
    End If
End Sub




Private Sub Application_NewMail()
    If MsgBox("Masz now wiadomo e-mail. Czy chcesz wywietli zawarto skrzynki odbiorczej?", _
        vbYesNo + vbInformation, "Powiadomienie o nowej wiadomoci e-mail") = vbYes Then
        Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Display
    End If
End Sub





Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)
MsgBox "Wyszukiwanie zakoczyo si. Znaleziono " & _
        SearchObject.Results.Count & " wynikw.", vbOKOnly + vbInformation, _
        "Zdarzenie AdvancedSearchComplete"
End Sub



Private Sub Application_AdvancedSearchStopped(ByVal SearchObject As Search)
    MsgBox "Wyszukiwanie zostao zatrzymane za pomoc polecenia Stop.", vbOKOnly
End Sub



Private Sub Application_MAPILogonComplete()

    Dim strMsg As String

    'tutaj naley zadeklarowa zmienne strPubDowBegin i strPubForecast i przypisa do nich dane

    strMsg = "Witamy w Systemie Sprzeday UltraBroker !" & vbCr & vbCr
    strMsg = strMsg & "Dzisiejsza warto rozpoczcia to " & strPubDowBegin & "." _
         & vbCr & vbCr
    strMsg = strMsg & "Dzisiejsza prognoza sprzeday: " & strPubForecast & "."
    MsgBox strMsg, vbOKOnly + vbInformation, _
         "Powitanie w Systemie Sprzeday UltraBroker"
End Sub




Private Sub Application_Startup()

Set objMyPublicContactItem = Application.GetNamespace("MAPI") _
    .GetDefaultFolder(olFolderContacts).Items(1)

End Sub




Private Sub myTaskItem_BeforeDelete(ByVal Item As Object, Cancel As Boolean)
    If myTaskItem.Complete = False Then
        MsgBox "Zakocz zadanie przed jego usuniciem.", _
            vbOKOnly + vbExclamation, "Zadanie nie jest zakoczone"
        Cancel = True
    End If
End Sub




Public WithEvents myInspectors As Inspectors
Public WithEvents myInspector As Inspector

Private Sub myInspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
    With Inspector
        With .CommandBars
            .Item("Standard").Visible = True
            .Item("Advanced").Visible = False
        End With
        Set myInspector = Inspector
    End With
End Sub

Private Sub myInspector_Activate()
    myInspector.WindowState = olMaximized
End Sub







Private Sub mySyncObject_OnError(ByVal Code As Long, _
    ByVal Description As String)

    Dim strMessage As String
    strMessage = "Wystpi bd podczas synchronizacji:" & vbCr & vbCr
    strMessage = strMessage & "Kod bdu: " & Code & vbCr
    strMessage = strMessage & "Opis bdu: " & Description
    MsgBox strMessage, vbOKOnly + vbExclamation, "Bd synchronizacji"

End Sub



Rozdzia 28.


'------------------------------------------------------------
' test
'
'------------------------------------------------------------
Function test()
On Error GoTo test_Err

    Standard_Setup


test_Exit:
    Exit Function

test_Err:
    MsgBox Error$
    Resume test_Exit

End Function


'------------------------------------------------------------
' test1
'
'------------------------------------------------------------
Function test1()
    Run_SampleProcedure
End Function




Sub ContactAccess()
Dim myAccess As Access.Application
Dim myDatabase As Object

Set myAccess = GetObject(, "Access.Application")
myAccess.CloseCurrentDatabase
myAccess.OpenCurrentDatabase _
    filepath:="C:\Temp\Northwind.accdb", Exclusive:=True
Set myDatabase = myAccess.CurrentDb
End Sub





Sub test()

Dim myWorkspace As Workspace
Set myWorkspace = DBEngine.Workspaces(0)

Dim myDatabase As Database
Dim RecSet As Recordset


Set myDatabase = myWorkspace.OpenDatabase _
    (Name:="C:\temp\northwind.accdb", _
    Options:=True, ReadOnly:=False)

Set RecSet = myDatabase.OpenRecordset("Klienci", dbOpenDynaset)

    MsgBox ("Cze! Te dane o miecie odczytaem z niewidocznego egzemplarza bazy danych Northwind: " & RecSet!Miasto)

 RecSet.Close
 myDatabase.Close


End Sub



On Error Resume Next

Dim strName As String
Dim strType As String

strType = "Formularz"
strName = Screen.ActiveForm.Name
If Err = 2475 Then
    Err = 0
    strType = "Raport"
    strName = Screen.ActiveReport.Name
    If Err = 2476 Then
        Err = 0
        strType = "Strona dostpu do danych"
        strName = Screen.ActiveDataAccessPage.Name
        If Err = 2022 Then
            Err = 0
            strType = "Arkusz danych"
            strName = Screen.ActiveDatasheet.Name
        End If
    End If
End If

MsgBox "Biecy obiekt Screen to: " & strType & vbCr _
    & vbCr & "Nazwa obiektu Screen to: " & strName, _
    vbOKOnly + vbInformation, "Biecy obiekt Screen"



Sub test ()

DoCmd.OpenForm FormName:="Formularz analizy sprzeday", View:=acNormal, _
WhereCondition:="Pracownik='Jan Kotas'"

End Sub



Rozdzia 29.



Dim myPowerPoint As PowerPoint.Application
Dim myPresentation As Presentation
Dim mySlide As Slide
Set myPowerPoint = CreateObject("PowerPoint.Application")
Set myPresentation = myPowerPoint.Presentations.Add
Set mySlide = myPresentation.Slides.Add(Index:=1, Layout:=ppLayoutTitleOnly)

Dim myOutlook As Object
Set myOutlook = CreateObject("Outlook.Application")



Sub Return_a_Value_from_Excel()

       Dim mySpreadsheet As Excel.Workbook
       Dim strSalesTotal As String

       Set mySpreadsheet = _
           GetObject("C:\Temp\Book1.xlsx")

       strSalesTotal = 
mySpreadsheet.Application.ActiveSheet.Range("A1").Value


       Set mySpreadsheet = Nothing

       Selection.TypeText "Bieca cakowita warto sprzeday: " & strSalesTotal & "PLN."

       Selection.TypeParagraph

   End Sub




Sub Send_Word_Count_to_Excel_Spreadsheet()

    Dim WordCount As Variant
    Dim strPath As String
    Dim strFile As String
    Dim docCurDoc As Document
    Dim myXL As Excel.Application
    Dim myXLS As Excel.Workbook
    Const errExcelNotRunning = 429
    Const errDocNotAvailable = 5174

    On Error GoTo Handle

    'otwarcie dokumentu Worda:
    strPath = "C:\temp"
    strFile = "test.docm"
    Set docCurDoc = Documents.Open(strPath & "\" _
        & strFile, AddToRecentFiles:=False)


    'czy Excel ju dziaa?
    Set myXL = GetObject(, "Excel.application")

    myXL.Visible = True
    Set myXLS = myXL.Workbooks.Add
    myXL.ActiveCell.Range("A1").Select
    myXL.ActiveCell = "Word Count"

    WordCount = docCurDoc _
        .BuiltInDocumentProperties(wdPropertyWords)

        myXL.ActiveCell.Range("A2").Select
        myXL.ActiveCell = WordCount

        docCurDoc.Close SaveChanges:=wdDoNotSaveChanges

Shutdown:
    Set myXL = Nothing
    Set myXLS = Nothing

    Exit Sub

Handle:
     If Err.Number = errExcelNotRunning Then
        ' Jeli nie uruchomiono egzemplarza Excela, uruchom go:
        Set myXL = CreateObject("Excel.Application")
        Err.Clear
        Resume Next
    ElseIf Err.Number = errDocNotAvailable Then
        MsgBox "Nie znalziono dokumentu Worda o nazwie Test.docm"
        GoTo Shutdown
    Else
        Resume Next
    End If

End Sub






Sub Notify_of_New_Presentation()

    Dim myPresentation As Presentation
    Dim strPresentationFilename As String
    Dim strPresentationTitle As String
    Dim strPresentationPresenter As String
    Dim myOutlook As Outlook.Application
    Dim myMessage As Outlook.MailItem
    Const errOutlookNotRunning = 429

    On Error GoTo ErrorHandler

    Set myPresentation = ActivePresentation
    With myPresentation
        strPresentationFilename = .FullName
        strPresentationTitle = _
            .Slides(1).Shapes(3).TextFrame.TextRange.Text
        strPresentationPresenter = _
            .Slides(1).Shapes(1).TextFrame.TextRange.Text
    End With

    Set myOutlook = GetObject(, "Outlook.Application")
    Set myMessage = myOutlook.CreateItem(ItemType:=olMailItem)
    With myMessage
    'zastp nastpny wiersz prawidowym adresem e-mail:
         .To = "richard41@pri.r.com"

        .Subject = "Presentation for review: " & strPresentationTitle
        .BodyFormat = olFormatHTML
        .Body = "Prosz zapozna si z nastpujc prezentacj:" & _
               vbCr & vbCr & "Tytu: " & strPresentationTitle & vbCr & _
               "Prezenter: " & strPresentationPresenter & vbCr & vbCr & _
               "Prezentacja jest w pliku: " & _
               strPresentationFilename
        .Send
    End With

    myOutlook.Quit

    Set myMessage = Nothing
    Set myOutlook = Nothing
    Exit Sub
ErrorHandler:
    If Err.Number = errOutlookNotRunning Then
        Set myOutlook = CreateObject("Outlook.Application")
        Err.Clear
        Resume Next
    Else
        MsgBox Err.Number & vbCr & Err.Description, vbOKOnly + _
            vbCritical, "Wystpi bd"
  End If

End Sub




Sub OpenIE()

Dim id

id = Shell("c:\program files\internet explorer\iexplore.exe", vbMaximizedFocus)

End Sub






Sub StoreText()

   Dim myDObj As DataObject

   Set myDObj = New DataObject

   myDObj.SetText "Przykadowy cig tekstowy"

   MsgBox myDObj.GetText


End Sub




Sub ManageClipboard()

Dim myDO As New MSForms.DataObject

myDO.SetText "Nasta Gomes"
myDO.PutInClipboard

myDO.GetText
MsgBox myDO.GetText


End Sub




If myDO.GetFormat("myHTML") = True Then _
    strHTMLText = myDO.GetText(Format:="myHTML")



Dim lngDDEChannel1 As Long
lngDDEChannel1 = DDEInitiate("Excel", "Wyniki sprzeday.xlsm")



Dim lngDDE1 As Long
Dim strDDETopics As String
lngDDE1 = DDEInitiate(App:="FrontPage", Topic:="System")
strDDETopics = DDERequest(Channel:=lngDDE1, Item:="Topics")


Sub DDEtoExcel()

Dim lngDDEChannel1 As Long, strResult As String
lngDDEChannel1 = DDEInitiate("Excel", "Tygodniowy terminarz posikw1")
strResult = DDERequest(lngDDEChannel1, "R11C4")
MsgBox strResult
DDETerminateAll

End Sub




Sub DDEPokeExcel()

Dim lngDDEChannel1 As Long, strResult As String

lngDDEChannel1 = DDEInitiate("Excel", "Tygodniowy terminarz posikw1")
strResult = DDERequest(lngDDEChannel1, "R11C4")


DDEPoke Channel:=lngDDEChannel1, Item:="R11C4", _
     Data:="Saatka ziemniaczana"
DDETerminateAll

End Sub



Sub DDEExec()

Dim lngMyChannel
lngMyChannel = DDEInitiate(App:="Excel", Topic:="System")
DDEExecute lngMyChannel, Command:="[Close]"

End Sub



Dim lngMyChannel
lngMyChannel = DDEInitiate(App:="Excel", Topic:="System")
DDEExecute lngMyChannel, Command:="[Close]"
DDETerminate lngMyChannel





Sub Send_to_Notepad()
    Dim strLogDate As String
    Dim strSaveLog As String
    Dim strMsg As String
    Dim appNotepad As Variant
    strMsg = "Przykadowy tekst loga."
    strLogDate = Day(Now) & "-" & Month(Now) & "-" & Year(Now)
    strSaveLog = "Log z dnia " & strLogDate & ".txt"
    appNotepad = Shell("notepad.exe", vbNormalFocus)
    AppActivate appNotepad
    SendKeys strMsg & "%FS" & strSaveLog & "{Enter}" & "%{F4}", True
End Sub





Sub Send_to_Excel()

    Dim appExcel As Variant

    appExcel = Shell("Excel.exe", vbNormalFocus)
    AppActivate appExcel
        SendKeys "%", True 'przesanie samego klawisza Alt
    SendKeys "O", True 'O wybiera zakadk Widok
    SendKeys "", True ' wcza tryb penego ekranu

End Sub
















































